frmdlpayment.frm

金算盘软件代码

    Dim strSql As String
    Dim strSelect As String
    Dim strField1 As String
    Dim strField2 As String
    Dim strTable As String
    Dim strCondVersion As String
    
    'strCondVersion = " And (ViewField.bytVersion Mod " & gVersionType * 2 & ">=" & gVersionType & ")"
    strCondVersion = " And (MOD(ViewField.bytVersion ," & gVersionType * 2 & ")>=" & gVersionType & ")"
    'Strsql = "SELECT DISTINCTROW ViewField.strViewFieldDesc FROM ViewField,List,ListField " _
        & "WHERE ViewField.lngViewFieldID=listField.lngViewFieldID " _
        & "AND List.lngListID=ListField.lngListID And List.lngViewID=" _
        & lngViewID2 & " And ListField.blnIsChoosed=True " & strCondVersion _
        & " AND List.lngOperatorID=" & gclsBase.OperatorID & "  ORDER BY ListField.lngListFieldNo"
    'Set recView2 = gclsBase.BaseDB.OpenRecordset(Strsql, dbOpenSnapshot)
    
    strSql = "SELECT DISTINCT ViewField.strViewFieldDesc FROM ViewField,List,ListField " _
        & "WHERE ViewField.lngViewFieldID=listField.lngViewFieldID " _
        & "AND List.lngListID=ListField.lngListID And List.lngViewID=" _
        & lngViewID2 & " And ListField.blnIsChoosed=1 " & strCondVersion _
        & " AND List.lngOperatorID=" & gclsBase.OperatorID
        '& "  ORDER BY ListField.lngListFieldNo"
    Set recView2 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    
    If recView2.EOF Then
        'Strsql = "SELECT ViewField.strViewFieldDesc FROM View INNER JOIN ViewField " _
            & "ON View.lngViewID=ViewField.lngViewID " _
            & "WHERE (ViewField.blnIsFixed=True Or Viewfield.blnIsMust=True " _
            & "Or ViewField.blnIsPrep=True) AND View.lngViewID=" & lngViewID2 & strCondVersion _
            & " ORDER BY ViewField.lngViewFieldNO"
        'Set recView2 = gclsBase.BaseDB.OpenRecordset(Strsql, dbOpenSnapshot)
        
        strSql = "SELECT ViewField.strViewFieldDesc FROM View1 , ViewField " _
            & " WHERE View1.lngViewID=ViewField.lngViewID " _
            & " AND (ViewField.blnIsFixed=1 Or Viewfield.blnIsMust=1 " _
            & " Or ViewField.blnIsPrep=1) AND View1.lngViewID=" & lngViewID2 & strCondVersion _
            & " ORDER BY ViewField.lngViewFieldNO"
        Set recView2 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    End If
    If Not recView2.EOF Then
        'Strsql = "SELECT ViewField.* FROM View INNER JOIN ViewField " _
            & "ON View.lngViewID=ViewField.lngViewID " _
            & "WHERE View.lngViewID=" & lngViewID1
        'Set recView1 = gclsBase.BaseDB.OpenRecordset(Strsql, dbOpenSnapshot)
        Do While Not recView2.EOF
            'recView1.FindFirst "strViewFieldDesc='" & recView2!strViewFieldDesc & "'"
            
            strSql = "SELECT ViewField.* FROM View1 , ViewField " _
                   & " WHERE View1.lngViewID=ViewField.lngViewID " _
                   & " AND View1.lngViewID=" & lngViewID1 _
                   & " AND strViewFieldDesc='" & recView2!strViewFieldDesc & "'"
            Set recView1 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            
            'If recView1.NoMatch Then
            If recView1.EOF Then
                strField1 = "'' AS " & recView2!strViewFieldDesc
            Else
                strField1 = recView1!strFieldName & " AS " & recView2!strViewFieldDesc
            End If
            If strSelect = "" Then
                strSelect = "," & strField1
            Else
                strSelect = strSelect & "," & strField1
            End If
            If Format(recView1!strCombine, "!;") <> "" Then
                strTable = Format(recView1!strTableName, "!;")
                If InStr(strFrom, strTable & " ") = 0 Then
                    If IsNumeric(Right(strTable, 1)) Then
                        strField1 = "lng" & Left(strTable, Len(strTable) - 1) & "ID"
                        strField2 = "lng" & Left(strTable, Len(strTable) - 1) & "ID" & Right(strTable, 1)
                    Else
                        strField1 = "lng" & strTable & "ID"
                        strField2 = "lng" & strTable & "ID"
                    End If
                    strFrom = "(" & strFrom & ") LEFT JOIN " & strTable & " ON " _
                        & recView1!strCombine & "." & strField2 & "=" & strTable & "." & strField1
                End If
            End If
            recView1.Close
            recView2.MoveNext
        Loop
'        recView1.Close
    End If
    recView2.Close
    GetSelectFromView = strSelect
End Function

'初始化各金额Label框中数据
Private Sub ShowTotalRow()
    Dim intCount As Integer
    Dim dblBalance As Double
    Dim dblAmount As Double
    Dim intBalCol As Integer
    Dim intChkCol As Integer
    'Dim recSet As Recordset
    Dim recSET As rdoResultset
    Dim blnNoData As Boolean

    On Error GoTo Err

    blnNoData = True
    dblBalance = 0
    dblAmount = 0
    mdblLastChkAmt = 0
    'If Not datAP.Recordset Is Nothing Then
    '    If Not datAP.Recordset.EOF Then
    '        With datAP.Recordset
    If Not datAP.Resultset Is Nothing Then
        If Not datAP.Resultset.EOF Then
            With datAP.Resultset
                blnNoData = False
                .MoveFirst
                Do While Not .EOF
                    
                    'mdblLastChkAmt = mdblLastChkAmt + Format(.Fields("原核销金额"), "@;0")
                    'dblBalance = dblBalance + Format(.Fields("未核销金额"), "@;0")
                    'dblAmount = dblAmount + Format(.Fields("本次核销"), "@;0")
                    
                    mdblLastChkAmt = mdblLastChkAmt + Format(datAP.Resultset("原核销金额"), "@;0")
                    dblBalance = dblBalance + Format(datAP.Resultset("未核销金额"), "@;0")
                    dblAmount = dblAmount + Format(datAP.Resultset("本次核销"), "@;0")
                    
                    .MoveNext
                Loop
            End With
        End If
    End If
    If blnNoData Or dblBalance = 0 Then
        hLb(mintBalAmtCol).Caption = ""
    Else
        hLb(mintBalAmtCol).Caption = strFormat(dblBalance, mintCurrencyDec)
    End If
    If blnNoData Or dblAmount = 0 Then
        hLb(mintEditAmtCol).Caption = ""
    Else
        hLb(mintEditAmtCol).Caption = strFormat(dblAmount, mintCurrencyDec)
    End If
    Exit Sub

Err:
   ShowMsg Me.hwnd, "数据初始化时失败 ", MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "应付核销"
End Sub


'响应核销内容筛选操作
Private Sub FilterData()
    Dim lngRow As Long
    Dim strCustomer As String
    
    On Error GoTo Err
    
    If mblnModify Then
       If ShowMsg(Me.hwnd, "筛选后，你刚刚做的结算将被取消，需要先存盘吗？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "应付款核销") = IDYES Then
          SaveData False
       Else
          mdblPayAmount = mdblPayAmount + C2Dbl(hLb(mintEditAmtCol).Caption)
          lblPayAmount.Caption = strFormat(mdblPayAmount, mintCurrencyDec)
          hLb(mintEditAmtCol).Caption = ""
        End If
    End If
    If mclsGrid.ListSet.ListID < 1 Then
       mclsGrid.ListSet.SaveList
    End If
    strCustomer = "单位/" & mstrCustomerName & "/" & mlngCustomerID
    Filter.ShowFilter mclsGrid.ListSet.ListID, 1, , , , , , strCustomer
    mclsGrid.ListSet.SaveList
    msgGrid.Rows = 1
    msgGrid.FixedCols = 0
    'Set datAP.Recordset = GetList()
    Set datAP.Resultset = GetList()
    FindColPosition
    mclsGrid.ColOfs = mlngOffsetCol
    mclsGrid.SetupStyle
    Exit Sub

Err:
     ShowMsg Me.hwnd, "在进行筛选操作时失败！  ", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "应付款核销"
End Sub

'入参 ： blnQuit=False是存盘不关闭窗体，blnQuit=true是存盘关闭窗体
'功能 ： 响应存盘操作
Private Sub SaveData(blnQuit As Boolean)         '存盘
    Dim intAmtCol As Integer
    Dim intQtyCol As Integer
    Dim dblChkAmount As Double
    Dim dblChkQuantity As Double
    Dim dblLastQuantity As Double
    Dim dblLastAmount As Double
    Dim strSql As String
    Dim lngRow As Long
    
    On Error GoTo Err
    
    intAmtCol = mintEditAmtCol
    intQtyCol = mintEditQtyCol
    
    dblChkAmount = C2Dbl(hLb(intAmtCol).Caption)
    strSql = "UPDATE ActivityDetail SET dblCurrPaymentAmount=" & dblChkAmount & " " _
        & "WHERE lngActivityDetailID=" & mlngCashDetailID
    gclsBase.ExecSQL strSql
    
    For lngRow = 1 To msgGrid.Rows - 1
        '前后有否变化
        If GetValue(lngRow, mintLastChkAmtCol) <> GetValue(lngRow, intAmtCol) Then
            dblLastQuantity = GetValue(lngRow, mintLastChkQtyCol) * GetValue(lngRow, mintARAPFlagCol)
            dblLastAmount = GetValue(lngRow, mintLastChkAmtCol) * GetValue(lngRow, mintARAPFlagCol)
            dblChkAmount = GetValue(lngRow, intAmtCol) * GetValue(lngRow, mintARAPFlagCol)
            
            If intQtyCol > 0 Then
                dblChkQuantity = NormalToMinQty(GetValue(lngRow, intQtyCol) * GetValue(lngRow, mintARAPFlagCol), GetValue(lngRow, mintFactorCol))
            Else
                dblChkQuantity = Int(GetValue(lngRow, mintTotalQtyCol) * GetValue(lngRow, mintARAPFlagCol) * dblChkAmount / GetValue(lngRow, mintTotalAmtCol)) - dblLastQuantity
            End If
            '新增情况
            If (dblLastQuantity = 0 And dblLastAmount = 0 And (dblChkQuantity <> 0 Or dblChkAmount <> 0)) Then
                strSql = "INSERT INTO CashToARAP (lngCashActivityDetailID,strARAPSource,lngARAPActivityDetailID,dblPaymentQuantity,dblCurrPaymentAmount) " _
                    & "VALUES(" & mlngCashDetailID & "," & msgGrid.TextMatrix(lngRow, mintTableIDCol) & "," & GetValue(lngRow, mintDetailIDCol) & "," & dblChkQuantity & "," & dblChkAmount & ")"
                gclsBase.ExecSQL strSql
                Select Case GetValue(lngRow, mintTableIDCol)
                Case 1 '业务表
                    strSql = "UPDATE ActivityDetail SET dblCurrPaymentAmount=dblCurrPaymentAmount+" & dblChkAmount & " " _
                        & "WHERE lngActivityDetailID=" & GetValue(lngRow, mintDetailIDCol)
                    gclsBase.ExecSQL strSql
                Case 2 '商品业务表
                    strSql = "UPDATE ItemActivityDetail SET dblPaymentQuantity=dblPaymentQuantity+" & dblChkQuantity & ",dblCurrPaymentAmount=dblCurrPaymentAmount+" & dblChkAmount & " " _
                        & "WHERE lngActivityDetailID=" & GetValue(lngRow, mintDetailIDCol)
                    gclsBase.ExecSQL strSql
                Case 0 '期初
                    strSql = "UPDATE ARAPInit SET dblPaymentQuantity=dblPaymentQuantity+" & dblChkQuantity & ",dblCurrPaymentAmount=dblCurrPaymentAmount+" & dblChkAmount & " " _
                        & "WHERE lngARAPInitID=" & GetValue(lngRow, mintDetailIDCol) & ""
                        gclsBase.ExecSQL strSql
                End Select
            Else        '更新情况
                dblChkAmount = dblChkAmount - dblLastAmount
                dblChkQuantity = dblChkQuantity - dblLastQuantity
                If GetValue(lngRow, mintIDSourceCol, "String") = "现金银行" Then
                    strSql = "UPDATE CashToARAP SET dblPaymentQuantity=dblPaymentQuantity+" & dblChkQuantity & ",dblCurrPaymentAmount=dblCurrPaymentAmount+" & dblChkAmount & " " _
                          & "WHERE lngARAPActivityDetailID=" & GetValue(lngRow, mintDetailIDCol)
                Else
                    strSql = "UPDATE CashToARAP SET dblPaymentQuantity=dblPaymentQuantity+" & dblChkQuantity & ",dblCurrPaymentAmount=dblCurrPaymentAmount+" & dblChkAmount & " " _
                          & "WHERE lngCashActivityDetailID=" & GetValue(lngRow, mintDetailIDCol)
                End If
                gclsBase.ExecSQL strSql
                      
                Select Case GetValue(lngRow, mintTableIDCol)
                Case 1  '业务表
                    strSql = "UPDATE ActivityDetail SET dblCurrPaymentAmount=dblCurrPaymentAmount+" & dblChkAmount & " " _
                        & "WHERE lngActivityDetailID=" & GetValue(lngRow, mintDetailIDCol)
                    gclsBase.ExecSQL strSql
                Case 2 '商品表
                    strSql = "UPDATE ItemActivityDetail SET dblPaymentQuantity=dblPaymentQuantity+" & dblChkQuantity & ",dblCurrPaymentAmount=dblCurrPaymentAmount+" & dblChkAmount & " " _
                        & "WHERE lngActivityDetailID=" & GetValue(lngRow, mintDetailIDCol)
                    gclsBase.ExecSQL strSql
                Case 0
                    strSql = "UPDATE ARAPInit SET dblPaymentQuantity=dblPaymentQuantity+" & dblChkQuantity & ",dblCurrPaymentAmount=dblCurrPaymentAmount+" & dblChkAmount & " " _
                        & "WHERE lngARAPInitID=" & GetValue(lngRow, mintDetailIDCol)
                    gclsBase.ExecSQL strSql
                End Select
            End If
        End If
    Next lngRow
    
    'Strsql = "DELETE * FROM CashtoARAP WHERE dblPaymentQuantity=0 AND dblCurrPaymentAmount=0"
    strSql = "DELETE FROM CashtoARAP WHERE dblPaymentQuantity=0 AND dblCurrPaymentAmount=0"
    gclsBase.ExecSQL strSql
    
    MousePointer = vbDefault
    mblnModify = False
    If blnQuit Then
       Unload Me
    End If
    Exit Sub

Err:
    MousePointer = vbDefault
    ShowMsg Me.hwnd, "存盘过程中遇到错误，存盘不成功 ", MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "应付款核销"
End Sub

'响应窗体按钮动作
Private Sub Cmdall_Click(Index As Integer)
    Select Case Index
    Case 6                                    '确定存盘
        If mblnModify Then
            SaveData True
        Else
            Unload Me
        End If
    Case 1                                    '取消
         Unload Me
    Case 3                                    '筛选
         MousePointer = vbHourglass
         FilterData
         MousePointer = vbDefault
    Case 2                                   '全部选择
         If msgGrid.Rows > 1 Then
            mnuCheckAll_Click
         End If
    Case 4                                    '栏目设置
         MousePointer = vbHourglass
         setColumn
         MousePointer = vbDefault
    Case 5
'         BillPublic.ShowBill GetValue(msgGrid.Row, 2), mlngCashDetailID         '关联到单据
    End Select
End Sub

'重定窗体中各控件的位置、大小
Private Sub Form_Resize()
    If mblnFormNoRezise Then Exit Sub
    If Me.WindowState = 1 Then
      Exit Sub
    End If
    
    On Error Resume Next