frmaccountinit.frm

金算盘软件代码

             " And WrAcntCurrency.CurrencyID=WrAcntDaily.lngCurrencyid(+)" & _
             " And WrAcntDaily.strAccountCode(+) Like  WrAcntCurrency.strAccountCode || '-%'" & _
             " And WrAcntCurrency.CurrencyID=Currencys.lngCurrencyID(+) And WrAcntCurrency.blnIsDetail=0" & _
             strWhere & strGroup
    
    strSql = strSql & strOrder
    
    Set mrstData = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    
    mGrid.RDORecordset = mrstData
    mGrid.Rows = mrstData.RowCount + 2
    mGrid.Cols = mrstData.rdoColumns.Count - 1
    
End Sub

'保存期初余额
Private Function SaveInit(ByVal dblNew As Double) As Boolean
    Dim recTemp As rdoResultset
    Dim strSql As String, strDirect As String
    Dim strSql1 As String, strsql2 As String
    Dim dblValue(8) As Double, dblUnVoucherValue(8) As Double, dblOldValue(2) As Double
    Dim dblDiffValue(2) As Double, dblDiffUnVoucherValue(2) As Double
    Dim blnFlag As Boolean
    Dim intCount As Integer
    Dim intFlag As Integer
    Dim blnIsZero As Boolean
    Dim blnIsExite As Boolean
    
    With mGrid
        blnFlag = IsCashBank(.CellValue(mlngRow, 0))
        strDirect = .CellValue(mlngRow, 3)
        For intCount = 0 To 8
            If mintCol = intCount + 6 Then
                dblValue(intCount) = dblNew
            Else
                If Trim(.CellValue(mlngRow, intCount + 6)) = "" Or .CellValue(mlngRow, intCount + 6) = "-" Then
                    dblValue(intCount) = 0
                Else
                    dblValue(intCount) = CDbl(IIf(IsNull(.CellValue(mlngRow, intCount + 6)), 0, .CellValue(mlngRow, intCount + 6)))
                End If
            End If
            If .CellValue(mlngRow, .Cols - 1) = "1" Then
                Select Case intCount
                    Case 1, 4, 7
                        dblValue(intCount - 1) = dblValue(intCount)
                End Select
            End If
        Next
        For intCount = 0 To 8
            If blnFlag Then
                dblUnVoucherValue(intCount) = dblValue(intCount)
            Else
                dblUnVoucherValue(intCount) = 0
            End If
        Next
        
        If strDirect = "借" Then
            strSql = "Insert Into AccountDaily (strDate,lngAccountID,lngCurrencyID" _
                & ",dblCurrencyPostedDebit,dblPostedDebit,dblQuantityPostedDebit" _
                & ",dblCurrencyUnVoucherDebit,dblUnVoucherDebit,dblQuantityUnVoucherDebit)" _
                & " Values ('" & Format(DateAdd("D", -1, gclsBase.FirstDate), "yyyy-mm-dd") & "'," & .CellValue(mlngRow, 0) & "," _
                & .CellValue(mlngRow, .Cols - 1) & "," & dblValue(0) & "," & dblValue(1) _
                & "," & dblValue(2) & "," & dblUnVoucherValue(0) _
                & "," & dblUnVoucherValue(1) & "," & dblUnVoucherValue(2) & ")"
        Else
            strSql = "Insert Into AccountDaily (strDate,lngAccountID,lngCurrencyID" _
                & ",dblCurrencyPostedCredit,dblPostedCredit,dblQuantityPostedCredit" _
                & ",dblCurrencyUnVoucherCredit,dblUnVoucherCredit,dblQuantityUnVoucherCredit)" _
                & " Values ('" & Format(DateAdd("D", -1, gclsBase.FirstDate), "yyyy-mm-dd") & "'," & .CellValue(mlngRow, 0) & "," _
                & .CellValue(mlngRow, .Cols - 1) & "," & dblValue(0) & "," & dblValue(1) _
                & "," & dblValue(2) & "," & dblUnVoucherValue(0) _
                & "," & dblUnVoucherValue(1) & "," & dblUnVoucherValue(2) & ")"
        End If
        
        If gclsBase.BeginDate <> gclsBase.FirstDate Then
            strsql2 = "Insert Into AccountDaily (strDate,lngAccountID,lngCurrencyID" _
                & ",dblCurrencyPostedDebit,dblPostedDebit,dblQuantityPostedDebit" _
                & ",dblCurrencyPostedCredit,dblPostedCredit,dblQuantityPostedCredit" _
                & ",dblCurrencyUnVoucherDebit,dblUnVoucherDebit,dblQuantityUnVoucherDebit" _
                & ",dblCurrencyUnVoucherCredit,dblUnVoucherCredit,dblQuantityUnVoucherCredit)" _
                & " Values ('" & mstrDate & "'," & .CellValue(mlngRow, 0) & "," _
                & .CellValue(mlngRow, .Cols - 1) & "," & dblValue(3) & "," & dblValue(4) & "," _
                & dblValue(5) & "," & dblValue(6) & "," & dblValue(7) & "," & dblValue(8) & "," _
                & dblUnVoucherValue(3) & "," & dblUnVoucherValue(4) & "," & dblUnVoucherValue(5) & "," _
                & dblUnVoucherValue(6) & "," & dblUnVoucherValue(7) & "," & dblUnVoucherValue(8) & ")"
        End If
        
        On Error GoTo errhandel:
        'gclsBase.BaseWorkSpace.BeginTrans
        intFlag = 1
        If strSql <> "" Then gclsBase.BaseDB.Execute strSql
        
        intFlag = 3
        If strsql2 <> "" Then gclsBase.BaseDB.Execute strsql2
        'gclsBase.BaseWorkSpace.CommitTrans
        Exit Function
errhandel:
        Select Case Err.Number
            Case 3022, 40002
                Select Case intFlag
                    Case 1
                       If strDirect = "借" Then
                            strSql = "Update AccountDaily Set dblCurrencyPostedDebit=" _
                                & dblValue(0) & ",dblPostedDebit=" & dblValue(1) _
                                & ",dblQuantityPostedDebit=" & dblValue(2) _
                                & ",dblCurrencyUnVoucherDebit=" & dblUnVoucherValue(0) _
                                & ",dblUnVoucherDebit=" & dblUnVoucherValue(1) _
                                & ",dblQuantityUnVoucherDebit=" & dblUnVoucherValue(2) _
                                & ",dblCurrencyPostedCredit=0" _
                                & ",dblPostedCredit=0" _
                                & ",dblQuantityPostedCredit=0" _
                                & ",dblCurrencyUnVoucherCredit=0" _
                                & ",dblUnVoucherCredit=0" _
                                & ",dblQuantityUnVoucherCredit=0" _
                                & " Where strDate='" & Format(DateAdd("D", -1, gclsBase.FirstDate), "yyyy-mm-dd") & "' And lngAccountID = " _
                                & .CellValue(mlngRow, 0) & " And lngCurrencyID=" & .CellValue(mlngRow, .Cols - 1) _
                                & " And lngCustomerID=0 And lngDepartmentID=0 And lngEmployeeID=0" _
                                & " And lngClassID1=0 And lngClassID2=0"
                       Else
                            strSql = "Update AccountDaily Set dblCurrencyPostedCredit=" _
                                & dblValue(0) & ",dblPostedCredit=" & dblValue(1) _
                                & ",dblQuantityPostedCredit=" & dblValue(2) _
                                & ",dblCurrencyUnVoucherCredit=" & dblUnVoucherValue(0) _
                                & ",dblUnVoucherCredit=" & dblUnVoucherValue(1) _
                                & ",dblQuantityUnVoucherCredit=" & dblUnVoucherValue(2) _
                                & ",dblCurrencyPostedDebit=0" _
                                & ",dblPostedDebit=0" _
                                & ",dblQuantityPostedDebit=0" _
                                & ",dblCurrencyUnVoucherDebit=0" _
                                & ",dblUnVoucherDebit=0" _
                                & ",dblQuantityUnVoucherDebit=0" _
                                & " Where strDate='" & Format(DateAdd("D", -1, gclsBase.FirstDate), "yyyy-mm-dd") & "' And lngAccountID = " _
                                & .CellValue(mlngRow, 0) & " And lngCurrencyID=" & .CellValue(mlngRow, .Cols - 1) _
                                & " And lngCustomerID=0 And lngDepartmentID=0 And lngEmployeeID=0" _
                                & " And lngClassID1=0 And lngClassID2=0"
                       End If
                    Case 3
                        strsql2 = "Update AccountDaily Set dblCurrencyPostedDebit=" & dblValue(3) & ",dblPostedDebit=" _
                            & dblValue(4) & ",dblQuantityPostedDebit=" & dblValue(5) & ",dblCurrencyPostedCredit=" _
                            & dblValue(6) & ",dblPostedCredit=" & dblValue(7) & ",dblQuantityPostedCredit=" & dblValue(8) _
                            & ",dblCurrencyUnVoucherDebit=" & dblUnVoucherValue(3) & ",dblUnVoucherDebit=" _
                            & dblUnVoucherValue(4) & ",dblQuantityUnVoucherDebit=" & dblUnVoucherValue(5) & ",dblCurrencyUnVoucherCredit=" _
                            & dblUnVoucherValue(6) & ",dblUnVoucherCredit=" & dblUnVoucherValue(7) & ",dblQuantityUnVoucherCredit=" _
                            & dblUnVoucherValue(8) & " Where strDate='" & mstrDate & "' And lngAccountID = " _
                            & .CellValue(mlngRow, 0) & " And lngCurrencyID=" & .CellValue(mlngRow, .Cols - 1) _
                            & " And lngCustomerID=0 And lngDepartmentID=0 And lngEmployeeID=0" _
                            & " And lngClassID1=0 And lngClassID2=0"
                End Select
                Resume
            Case Else
                ShowMsg Me.hwnd, "科目期初余额录入失败！", vbOKOnly + vbCritical, "科目期初余额录入提示"
                'gclsBase.BaseWorkSpace.RollBacktrans
                Exit Function
        End Select
    End With
End Function

'录入完成
Private Function InputFinish(strText As Variant, Optional IsTotal As Boolean = True) As Boolean
    Dim dblOldValue As Double
    Dim dblOldSub(1) As Double
    Dim dblSub(1) As Double
    Dim strDirect As String
    Dim intCount As Integer

    With mGrid
            If IsNumeric(strText) Or Trim(strText) = "" Then
                If Trim(strText) = "" Then
                    dblSub(0) = 0
                Else
                    dblSub(0) = CDbl(strText)
                End If
                Select Case mintCol
                    Case 6, 9, 12
                        If Trim(.CellValue(mlngRow, mintCol + 2)) <> "" And .CellValue(mlngRow, mintCol + 2) <> "-" Then
                            If dblSub(0) <> 0 Then
                                If dblSub(0) * CDbl(.CellValue(mlngRow, mintCol + 2)) < 0 Then
                                    'ShowMsg Me.hwnd, "金额的符号必须与数量相同，请重新输入！", vbInformation, Me.Caption
                                    'InputFinish = False
                                    'Exit Function
                                End If
                            End If
                        End If
                    Case 7, 10, 13
                        If Trim(.CellValue(mlngRow, mintCol + 1)) <> "" And .CellValue(mlngRow, mintCol + 1) <> "-" Then
                            If dblSub(0) <> 0 Then
                                If dblSub(0) * CDbl(.CellValue(mlngRow, mintCol + 1)) < 0 Then
                                    'ShowMsg Me.hwnd, "金额的符号必须与数量相同，请重新输入！", vbInformation, Me.Caption
                                    'InputFinish = False
                                    'Exit Function
                                End If
                            End If
                        End If
                    Case 8, 11, 14
                        If Trim(.CellValue(mlngRow, mintCol - 1)) <> "" And .CellValue(mlngRow, mintCol - 1) <> "-" Then
                            If dblSub(0) <> 0 Then
                                If dblSub(0) * CDbl(.CellValue(mlngRow, mintCol - 1)) < 0 Then
                                    'ShowMsg Me.hwnd, "数量的符号必须与金额相同，请重新输入！", vbInformation, Me.Caption
                                    'InputFinish = False
                                    'Exit Function
                                End If
                            End If
                        End If
                End Select
                If Trim(.CellValue(mlngRow, mintCol)) = "" Then
                    dblOldSub(0) = 0
                Else
                    dblOldSub(0) = CDbl(IIf(IsNull(.CellValue(mlngRow, mintCol)), 0, .CellValue(mlngRow, mintCol)))
                End If
                
                If dblSub(0) <> dblOldSub(0) Then
                    If (mintCol = 7 Or mintCol = 10 Or mintCol = 13) Then
                        If Trim(.CellValue(mlngRow, 16)) = "" Then
                            dblOldSub(1) = 0
                        Else
                            dblOldSub(1) = CDbl(IIf(IsNull(.CellValue(mlngRow, 16)), 0, .CellValue(mlngRow, 16)))
                        End If
                    End If
                    If mbytPeriod > 1 Then CalInit mlngRow, mintCol, dblSub(0)
                    If (mintCol = 7 Or mintCol = 10 Or mintCol = 13) And (.CellValue(mlngRow, 20) > "1" _
                        Or (.CellValue(mlngRow, 20) = "1" And .CellValue(mlngRow, 19) = "6")) Then
                        If Trim(.CellValue(mlngRow, 16)) = "" Then
                            dblSub(1) = 0
                        Else
                            dblSub(1) = CDbl(IIf(IsNull(.CellValue(mlngRow, 16)), 0, .CellValue(mlngRow, 16)))
                        End If
                        If Trim(.CellValue(mlngRow, 3)) = "" Then
                            intCount = 0
                            Do
                                intCount = intCount + 1
                            Loop Until Trim(.CellValue(mlngRow - intCount, 3)) <> ""
                            strDirect = .CellValue(mlngRow - intCount, 3)
                        Else
                            strDirect = .CellValue(mlngRow, 3)
                        End If
                        If IsTotal Then
                            If mintCol = 7 Then
                                If strDirect = "贷" Then
                                    ReCalPrefix .CellValue(mlngRow, 20), .CellValue(mlngRow, 19), -(dblSub(0) - dblOldSub(0)), -(dblSub(1) - dblOldSub(1))
                                Else
                                    ReCalPrefix .CellValue(mlngRow, 20), .CellValue(mlngRow, 19), dblSub(0) - dblOldSub(0), dblSub(1) - dblOldSub(1)
                                End If
                            Else
                                If strDirect = "贷" Then
                                    ReCalPrefix .CellValue(mlngRow, 20), .CellValue(mlngRow, 19), dblSub(0) - dblOldSub(0), -(dblSub(1) - dblOldSub(1))
                                Else
                                    ReCalPrefix .CellValue(mlngRow, 20), .CellValue(mlngRow, 19), dblSub(0) - dblOldSub(0), dblSub(1) - dblOldSub(1)
                                End If
                            End If
                        End If
                    End If
                    SaveInit dblSub(0)
                End If
                If dblSub(0) = 0 Then
                    strText = ""
                Else
                    Select Case mintCol
                        Case 6, 9, 12
                            '用Format有问题
                            '.SetCellDataType mlngRow, mintCol, mlngRow, mintCol, 1, 1, .CellValue(mlngRow, 18), -1
                            'strText = Format(dblSub(0), IIf(.CellValue(mlngRow, 18) = 0, "#,###,###,###", "#,###,###,##0." + String(.CellValue(mlngRow, 18), "0")))
                        Case 7, 10, 13
                            .SetCellDataType mlngRow, mintCol, mlngRow, mintCol, 1, 1, gclsBase.NaturalCurDec, -1
                            'strText = Format(dblSub(0), mstrDec)
                        Case 8, 11, 14
                            .SetCellDataType mlngRow, mintCol, mlngRow, mintCol, 1, 1, gclsBase.QuantityDec, -1
                            'strText = Format(dblSub(0), mstrQuantityDec)
                    End Select
                End If
                'mblnIsInput = False
                InputFinish = True
            Else
                If mintCol <= 3 Then
                    InputFinish = True
                Else
                    'ShowMsg Me.hwnd, "输入错误，请重新输入！", vbInformation, "科目期初录入提示"
                    InputFinish = False
                End If
            End If
    End With
End Function

'计算期初余额
Private Sub CalInit(ByVal Row As Long, ByVal col As Integer, ByVal dblNew As Double)
    Dim intCount As Integer
    Dim intCol As Integer
    Dim dblValue(3) As Double
    
    With mGrid