frmin_kmyetz.frm

一个用VB写的财务软件源码

'                        glo.cnnMain, adOpenStatic, adLockOptimistic
'                If .Fields(0).value > 0 Then
'                     If MsgBox("已有记账凭证请反记账再保存！", vbExclamation + vbOKOnly, "; 提示; ") = vbOK Then
'                       Exit Function
'                     End If
'                End If
'                .Close
'                Set rst10 = Nothing
'            End With
              oSaveBalance '保存余额
        Case "HELP"
            Call ShowHelp
        Case "EXIT"
            Unload Me
        End Select
End Function

'==================保存期初余额=============== true 保存有错
Private Function oSaveBalance() As Boolean
    On Error GoTo Err
    Dim arrXgFlag() As String '修改过数据的行的集合
    Dim iXgFlagCount As Integer '修改过数据的总行数
    Dim sSqlStr As String 'SQL字符串
    Dim sMonth As String '日期
    Dim sQcMonth As String
    Dim i As Integer, j As Integer
    
    cllBalance.SaveEdit '保存当前正在编辑的单元
    oSaveBalance = False
    If cllBalance.IsModified = 0 And sXgFlagMuster = "," Then MsgBox "当前没有要保存的数据！", vbExclamation, "提示": oSaveBalance = True: Exit Function
        If oCalcOperate(True) Then
        If MsgBox("期初会计计算不平衡，是否保存?", vbExclamation + vbYesNo, "提示") = vbNo Then
            oSaveBalance = True: Exit Function
        
        
        End If
    End If
    
     Dim rst10 As New ADODB.Recordset
        
           With rst10
                .Open "SELECT count(*) FROM tZW_pzsj" & glo.sOperateYear & _
                        " WHERE xgbz='2' AND kjqj = 1", _
                        glo.cnnMain, adOpenStatic, adLockOptimistic
                If .Fields(0).value > 0 Then
                     If MsgBox("已有记账凭证请反记账再保存！", vbExclamation + vbOKOnly, "; 提示; ") = vbOK Then
                        oSaveBalance = True: Exit Function
                     End If
                End If
                .Close
                Set rst10 = Nothing
            End With
    Picture1.Visible = True
    ProgressBar1.value = 0
    ProgressBar1.Min = 0
    ProgressBar1.Max = 100
    Me.MousePointer = vbHourglass
    arrXgFlag = Split(sXgFlagMuster, ",", -1, vbTextCompare) '把已经修改方向行拆分到数组
    glo.cnnMain.BeginTrans '事务开始
    With cllBalance
        iXgFlagCount = UBound(arrXgFlag) - 1
        For i = 1 To iXgFlagCount
            sSqlStr = ""
             '-----------
            sQcMonth = QcYue
            If Val(sQcMonth) = 0 Then sQcMonth = 13
            For j = 0 To Val(sQcMonth) - 1 '保存0到QcYue  ＝年初数
                sMonth = Format(j, "00")
                If arrFx(Val(arrXgFlag(i))) = "借" Then
                   sSqlStr = sSqlStr & ",ljjsl" & sMonth & "=" & CDbl(.GetCellDouble(uNcSlCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljjwb" & sMonth & "=" & CDbl(.GetCellDouble(uNcWbCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljj" & sMonth & "=" & CDbl(.GetCellDouble(uNcJeCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljdsl" & sMonth & "=" & 0 _
                                     & ",ljdwb" & sMonth & "=" & 0 _
                                     & ",ljd" & sMonth & "=" & 0
                Else
                   sSqlStr = sSqlStr & ",ljjsl" & sMonth & "=" & 0 _
                                     & ",ljjwb" & sMonth & "=" & 0 _
                                     & ",ljj" & sMonth & "=" & 0 _
                                     & ",ljdsl" & sMonth & "=" & CDbl(.GetCellDouble(uNcSlCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljdwb" & sMonth & "=" & CDbl(.GetCellDouble(uNcWbCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljd" & sMonth & "=" & CDbl(.GetCellDouble(uNcJeCol.iCol, Val(arrXgFlag(i)), 0))
                End If
            Next
            '----------
            For j = Val(sQcMonth) To 12  '保存QcYu到12 =　累计数+年初数
                sMonth = Format(j, "00")
                If arrFx(Val(arrXgFlag(i))) = "借" Then
                   sSqlStr = sSqlStr & ",ljjsl" & sMonth & "=" & CDbl(.GetCellDouble(uLjJslCol.iCol, Val(arrXgFlag(i)), 0)) + CDbl(.GetCellDouble(uNcSlCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljjwb" & sMonth & "=" & CDbl(.GetCellDouble(uLjJwbCol.iCol, Val(arrXgFlag(i)), 0)) + CDbl(.GetCellDouble(uNcWbCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljj" & sMonth & "=" & CDbl(.GetCellDouble(uLjJjeCol.iCol, Val(arrXgFlag(i)), 0)) + CDbl(.GetCellDouble(uNcJeCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljdsl" & sMonth & "=" & CDbl(.GetCellDouble(uLjDslCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljdwb" & sMonth & "=" & CDbl(.GetCellDouble(uLjDwbCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljd" & sMonth & "=" & CDbl(.GetCellDouble(uLjDjeCol.iCol, Val(arrXgFlag(i)), 0))
                Else
                   sSqlStr = sSqlStr & ",ljjsl" & sMonth & "=" & CDbl(.GetCellDouble(uLjJslCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljjwb" & sMonth & "=" & CDbl(.GetCellDouble(uLjJwbCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljj" & sMonth & "=" & CDbl(.GetCellDouble(uLjJjeCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljdsl" & sMonth & "=" & CDbl(.GetCellDouble(uLjDslCol.iCol, Val(arrXgFlag(i)), 0)) + CDbl(.GetCellDouble(uNcSlCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljdwb" & sMonth & "=" & CDbl(.GetCellDouble(uLjDwbCol.iCol, Val(arrXgFlag(i)), 0)) + CDbl(.GetCellDouble(uNcWbCol.iCol, Val(arrXgFlag(i)), 0)) _
                                     & ",ljd" & sMonth & "=" & CDbl(.GetCellDouble(uLjDjeCol.iCol, Val(arrXgFlag(i)), 0)) + CDbl(.GetCellDouble(uNcJeCol.iCol, Val(arrXgFlag(i)), 0))
                End If
            Next
            '-----------
            sSqlStr = "UPDATE tZW_balance" & glo.sOperateYear & " set " & Right(sSqlStr, Len(sSqlStr) - 1) & ",yefx='" & arrFx(Val(arrXgFlag(i))) & "方' WHERE kmdm='" & arrKmdm(Val(arrXgFlag(i))) & "'"
            glo.cnnMain.Execute sSqlStr
            '保存方向到科目表
            sSqlStr = "update tzw_km" & glo.sOperateYear & " set yefx='" & arrFx(Val(arrXgFlag(i))) & "方' where kmdm='" & arrKmdm(Val(arrXgFlag(i))) & "'"
            glo.cnnMain.Execute sSqlStr
            ProgressBar1.value = Int(i / iXgFlagCount * 100)
        Next '保存余额表结束
    End With
    glo.cnnMain.CommitTrans '提交事务
    sXgFlagMuster = "," '方向修改标志清空
    cllBalance.SetModified 0 '当前修改标志清空
    Picture1.Visible = False
    Me.MousePointer = vbDefault
    Exit Function
Err:
    glo.cnnMain.RollbackTrans
    oSaveBalance = True
    Picture1.Visible = False
    Me.MousePointer = vbDefault
    MsgBox "保存有错！", vbExclamation, "提示"
End Function
'==============定位行=================
Private Sub oLocateCol()
Dim strTemp As String
Dim i As Integer
    strTemp = Trim$("" & OneSeek(vbCrLf & "        请输入要查的科目：" & vbCrLf & vbCrLf & "（按代码查找时，请输入数字系列。）", "", "tZW_Km" & glo.sOperateYear, "Kmdm", "Kmmc", "找不到此科目！"))
    With cllBalance
        For i = iFixRows + 1 To iFixRows + iDataRows
            If Trim$("" & arrKmdm(i)) = strTemp Then
                .MoveToCell uKmdmCol.iCol, i
               Exit For
            End If
        Next i
    End With
End Sub

 '=====================平衡计算=========
 ' oCalcOperate=true 不平衡
 ' bDapFrm=true 跳出是否平衡窗体
Private Function oCalcOperate(ByVal bDapFrm As Boolean) As Boolean
Dim j As Integer
Dim frm As New frmIN_Kmyejc
Load frm
frm.dNcDfTotal = 0
frm.dNcJfTotal = 0
frm.dLjDfTotal = 0
frm.dLjJfTotal = 0
frm.dQcDfTotal = 0
frm.dQcJfTotal = 0

frm.dNcZc = 0
frm.dNcCb = 0
frm.dNcFz = 0
frm.dNcQy = 0
frm.dNcSy = 0

frm.dQcZc = 0
frm.dQcCb = 0
frm.dQcFz = 0
frm.dQcQy = 0
frm.dQcSy = 0
 
oCalcOperate = False
With cllBalance
    .SaveEdit
    For j = iFixRows + 1 To iDataRows + iFixRows
       If GetKmJc(Trim("" & arrKmdm(j))) = 0 Then
            If Trim$("" & arrFx(j)) = "借" Then
                frm.dNcJfTotal = frm.dNcJfTotal + Format(.GetCellDouble(uNcJeCol.iCol, j, 0), "0.00")
                frm.dQcJfTotal = frm.dQcJfTotal + Format(.GetCellDouble(uQcJeCol.iCol, j, 0), "0.00")
            Else
                frm.dNcDfTotal = frm.dNcDfTotal + Format(.GetCellDouble(uNcJeCol.iCol, j, 0), "0.00")
                frm.dQcDfTotal = frm.dQcDfTotal + Format(.GetCellDouble(uQcJeCol.iCol, j, 0), "0.00")
            End If
            frm.dLjJfTotal = frm.dLjJfTotal + Format(.GetCellDouble(uLjJjeCol.iCol, j, 0), "0.00")
            frm.dLjDfTotal = frm.dLjDfTotal + Format(.GetCellDouble(uLjDjeCol.iCol, j, 0), "0.00")
            
            Select Case Left(Trim("" & arrKmdm(j)), 1)
            Case "1"
                If Trim$("" & arrFx(j)) = "借" Then
                    frm.dQcZc = frm.dQcZc + Format(.GetCellDouble(uQcJeCol.iCol, j, 0), "0.00")
                    frm.dNcZc = frm.dNcZc + Format(.GetCellDouble(uNcJeCol.iCol, j, 0), "0.00")
                Else
                    frm.dQcZc = frm.dQcZc - Format(.GetCellDouble(uQcJeCol.iCol, j, 0), "0.00")
                    frm.dNcZc = frm.dNcZc - Format(.GetCellDouble(uNcJeCol.iCol, j, 0), "0.00")
                End If
            Case "2"
                If Trim$("" & arrFx(j)) = "借" Then
                    frm.dQcFz = frm.dQcFz - Format(.GetCellDouble(uQcJeCol.iCol, j, 0), "0.00")
                    frm.dNcFz = frm.dNcFz - Format(.GetCellDouble(uNcJeCol.iCol, j, 0), "0.00")
                Else
                    frm.dNcFz = frm.dNcFz + Format(.GetCellDouble(uNcJeCol.iCol, j, 0), "0.00")
                    frm.dQcFz = frm.dQcFz + Format(.GetCellDouble(uQcJeCol.iCol, j, 0), "0.00")
                End If
            Case "3"
                If Trim$("" & arrFx(j)) = "借" Then
                    frm.dNcQy = frm.dNcQy - Format(.GetCellDouble(uNcJeCol.iCol, j, 0), "0.00")
                    frm.dQcQy = frm.dQcQy - Format(.GetCellDouble(uQcJeCol.iCol, j, 0), "0.00")
                Else
                    frm.dNcQy = frm.dNcQy + Format(.GetCellDouble(uNcJeCol.iCol, j, 0), "0.00")
                    frm.dQcQy = frm.dQcQy + Format(.GetCellDouble(uQcJeCol.iCol, j, 0), "0.00")
                End If
            Case "4"
                If Trim$("" & arrFx(j)) = "借" Then
                    frm.dNcCb = frm.dNcCb + Format(.GetCellDouble(uNcJeCol.iCol, j, 0), "0.00")
                    frm.dQcCb = frm.dQcCb + Format(.GetCellDouble(uQcJeCol.iCol, j, 0), "0.00")
                 Else
                    frm.dNcCb = frm.dNcCb - Format(.GetCellDouble(uNcJeCol.iCol, j, 0), "0.00")
                    frm.dQcCb = frm.dQcCb - Format(.GetCellDouble(uQcJeCol.iCol, j, 0), "0.00")
                 End If
            Case "5"
                If Trim$("" & arrFx(j)) = "借" Then
                    frm.dNcSy = frm.dNcSy - Format(.GetCellDouble(uNcJeCol.iCol, j, 0), "0.00")
                    frm.dQcSy = frm.dQcSy - Format(.GetCellDouble(uQcJeCol.iCol, j, 0), "0.00")
                Else
                    frm.dNcSy = frm.dNcSy + Format(.GetCellDouble(uNcJeCol.iCol, j, 0), "0.00")
                    frm.dQcSy = frm.dQcSy + Format(.GetCellDouble(uQcJeCol.iCol, j, 0), "0.00")
                End If
           End Select
      End If
    Next j
    If Abs(frm.dNcZc + frm.dNcCb - (frm.dNcFz + frm.dNcQy + frm.dNcSy)) > 0.005 Then oCalcOperate = True
    If Abs(frm.dQcZc + frm.dQcCb - (frm.dQcFz + frm.dQcQy + frm.dQcSy)) > 0.005 Then oCalcOperate = True
    If Abs(frm.dNcJfTotal - frm.dNcDfTotal) > 0.005 Then oCalcOperate = True
    If Abs(frm.dLjJfTotal - frm.dLjDfTotal) > 0.005 Then oCalcOperate = True
    If Abs(frm.dQcJfTotal - frm.dQcDfTotal) > 0.005 Then oCalcOperate = True
    If bDapFrm Then
        frm.sYear = glo.sOperateYear
        If QcYue = "00" Then
            frm.FillGrid False
        Else
            frm.FillGrid True
        End If
        frm.Show vbModal, Me
    End If

End With
End Function
'================方向操作===============
Sub oDirectOperate()
Dim iRowTmp As Integer, i As Integer
Dim iCurrRow As Integer '行
Dim bIsXgzkm As Boolean
With cllBalance
    If iDataRows = 0 Then Exit Sub
    If bReadOnly Then
        MsgBox "只读状态，不允许更改科目方向！", vbInformation
        Exit Sub
    End If
    iCurrRow = .GetCurrentRow '当前行
    If iCurrRow <= iFixRows Then Exit Sub
    If iCurrRow < iFixRows + 1 Or iCurrRow > iFixRows + iDataRows Then Exit Sub
    If MsgBox("确认要更改科目" & arrKmmc(iCurrRow) & "(" & arrKmdm(iCurrRow) & ")的方向吗？" & vbCrLf & vbCrLf & "      " & arrFx(iCurrRow) & "-→" & IIf(arrFx(iCurrRow) = "借", "贷", "借"), vbQuestion + vbYesNo, "提示") = vbNo Then Exit Sub
    arrFx(iCurrRow) = IIf(arrFx(iCurrRow) = "借", "贷", "借")
    .s uFxCol.iCol, iCurrRow, .GetCurSheet, arrFx(iCurrRow) '改变方向
    .d uNcSlCol.iCol, iCurrRow, .GetCurSheet, -1 * (.GetCellDouble(uNcSlCol.iCol, iCurrRow, 0)) '年初*-1
    .d uNcWbCol.iCol, iCurrRow, .GetCurSheet, -1 * (.GetCellDouble(uNcWbCol.iCol, iCurrRow, 0))
    .d uNcJeCol.iCol, iCurrRow, .GetCurSheet, -1 * (.GetCellDouble(uNcJeCol.iCol, iCurrRow, 0))
    '已经有修改标志的行不添加修改标志
    If InStr(1, sXgFlagMuster, "," & iCurrRow & ",", vbTextCompare) = 0 Then
       sXgFlagMuster = sXgFlagMuster & iCurrRow & "," '添加当前行修改标志
    End If
    For i = iCurrRow + 1 To iFixRows + iDataRows '查找子科目
            If InStr(1, arrKmdm(i), arrKmdm(iCurrRow), vbTextCompare) > 0 Then
                If i = .GetCurrentRow + 1 Then
                    If MsgBox("是否影响其所有子科目?", vbQuestion + vbYesNo, "") = vbNo Then
                        bIsXgzkm = False
                    Else
                        bIsXgzkm = True
                    End If
                End If
                If bIsXgzkm Then '修改子科目方向
                    If arrFx(i) <> arrFx(iCurrRow) Then
                        .d uNcSlCol.iCol, i, .GetCurSheet, -1 * (.GetCellDouble(uNcSlCol.iCol, i, 0))
                        .d uNcWbCol.iCol, i, .GetCurSheet, -1 * (.GetCellDouble(uNcWbCol.iCol, i, 0))
                        .d uNcJeCol.iCol, i, .GetCurSheet, -1 * (.GetCellDouble(uNcJeCol.iCol, i, 0))
                    End If
                    arrFx(i) = arrFx(iCurrRow)
                    .s uFxCol.iCol, i, .GetCurSheet, arrFx(iCurrRow) '改变方向
                    If InStr(1, sXgFlagMuster, "," & i & ",", vbTextCompare) = 0 Then
                       sXgFlagMuster = sXgFlagMuster & i & "," '添加当前行方向修改标志
                    End If
                    If arrIsEndKM(i) Then
                        pCalcHzQc uNcSlCol.iCol, i