form1.frm

本人开发的商业财务软件

Private Function isBalance() As Boolean
    '校验借贷平衡
    Dim curDebit As Currency '借方合计
    Dim curCredit As Currency '贷方合计
    Dim curSum As Currency    '分析科目合计
    Dim curTemp As Currency
    Dim PZid As Long
    Dim rstPZfxtmp As New ADODB.Recordset  '临时分析科目记录集
    curDebit = 0
    curCredit = 0
    rstPZfxtmp.CursorLocation = adUseClient
    
    rst_Tmp_Ping.MoveFirst
    Do Until rst_Tmp_Ping.EOF
        If (rst_Tmp_Ping!借方金额 <> 0) And (rst_Tmp_Ping!贷方金额 <> 0) Then
            isBalance = False
            MsgBox "一条记录中同时存在借方金额和贷方金额同时非零", , "输入出错"
            Exit Function
        End If
        curDebit = curDebit + rst_Tmp_Ping!借方金额
        curCredit = curCredit + rst_Tmp_Ping!贷方金额
        '对分析科目累加校对，  '如果不存在分析科目则不必校对
        PZid = rst_Tmp_Ping!ID     ' 临时存储时分析科目中pizd 对应 凭证的中 记录号
        If rstPZfxtmp.State = adStateOpen Then
            rstPZfxtmp.Close
        End If
        rstPZfxtmp.Open "select * from tempFx where pzid = " & PZid, pubConn, adOpenDynamic, adLockOptimistic
        If rstPZfxtmp.RecordCount > 0 Then
            curSum = 0
            rstPZfxtmp.MoveFirst
            While Not rstPZfxtmp.EOF
                curSum = curSum + rstPZfxtmp!金额
                rstPZfxtmp.MoveNext
            Wend
            If rst_Tmp_Ping!贷方金额 <> 0 Then
                curTemp = rst_Tmp_Ping!贷方金额
            Else
                If rst_Tmp_Ping!借方金额 <> 0 Then
                    curTemp = rst_Tmp_Ping!借方金额
                Else
                    MsgBox "借方金额和贷方金额同时为零，本记录无意义", vbInformation, "记录金额为零"
                    isBalance = False
                    Exit Function
                End If
                
            End If
            
            If curTemp <> curSum Then
                MsgBox "分析科目累加，不等于相对应的凭证中的记录金额！", vbOKOnly, "分析科目累加出错"
                isBalance = False
                Exit Function
            End If
            
         End If
         rstPZfxtmp.Close
         

        
        '
        
        rst_Tmp_Ping.MoveNext
    Loop
    If curDebit <> curCredit Then
        MsgBox "借方金额和贷方金额不相等", , "借贷不平衡"
        isBalance = False
        Exit Function
    End If
    
    isBalance = True
End Function
Private Sub cmdAdd_Click()
     Load selKemu
     selKemu.isAddItem = True
     selKemu.Show vbModal
End Sub

Private Sub cmdDelete_Click()
  On Error GoTo DeleteErr
  If MsgBox("你确定要删除吗？?", _
            vbQuestion + vbYesNo + vbDefaultButton2, _
            "lisypro") _
            <> vbYes Then
     Exit Sub
  End If
  With rst_Tmp_Ping
    .Delete
    .MoveNext
    If .EOF Then .MoveLast
  End With
    isSavedCurrent = False
  Exit Sub
DeleteErr:
  MsgBox Err.Description
End Sub
Private Sub cmdFXAdd_Click()
    Dialog.Show vbModal
End Sub
Private Sub cmdNext_Click()
    Dim iMaxPZid As Long
    Dim iRecCur As Integer
    Dim strSql As String
    Dim rstTemp As New ADODB.Recordset
    Dim iPzid As Long '分析科目对应的凭证中的记录号（不是凭证号）
    iRecCur = Val(txtNumber.Text) + 1
    If iRecCur = 1 Then
        cmdPre.Enabled = False '记录号为1，将命令按钮变灰
    End If
    rstTemp.Open "select max(凭证号) as idx from PingZheng", pubConn
    If IsNull(rstTemp!idx) Then
             iMaxPZid = 0
             cmdNext.Enabled = False
    Else
            iMaxPZid = rstTemp!idx
            If iMaxPZid <= iRecCur Then cmdNext.Enabled = False
    End If
    rstTemp.Close
    txtNumber.Text = Str(iRecCur)  '更改显示凭证号文本框的值
    pubConn.Execute "delete * from tempPingZheng"
    pubConn.Execute "delete * from tempfx"
    strSql = "insert into tempPingZheng select 摘要,科目,科目编号,借方金额,贷方金额,记录号,id,原始凭证数,月凭证号   from PingZheng where 凭证号 = " & iRecCur
    pubConn.Execute strSql
    strSql = "insert into tempFx(科目,科目编号,记录号,金额,pzid) select 科目,编号,记录号,金额,pzid from PingZhengfx where 凭证号 =" & iRecCur
    pubConn.Execute strSql
    rstTemp.Open "select 日期  from PingZheng where" & Str(iRecCur), pubConn
        
    If rstTemp.RecordCount = 0 Then
        MsgBox "本凭证号无记录"
        Exit Sub
    End If
    If IsNull(rstTemp!日期) Then
             MsgBox "日期为空，数据出错"
             Exit Sub
         Else
            DTPicker1.Value = rstTemp!日期   '更改日期显示，显示当前凭证日期
    End If
    rstTemp.Close
    
    '更新datagrid1中显示凭证科目的内容
    If rst_Tmp_Ping.State = adStateOpen Then
        rst_Tmp_Ping.Close
    End If
    rst_Tmp_Ping.Open "select * from tempPingZheng order by id", pubConn, adOpenDynamic, adLockOptimistic
    rst_Tmp_Ping.MoveFirst
    Set DataGrid1.DataSource = rst_Tmp_Ping
    DataGrid1.Columns(0).Visible = False
    DataGrid1.Columns(1).Width = 1400
    DataGrid1.Columns(3).Width = 800
    DataGrid1.Columns(4).Width = 800
    DataGrid1.Columns(5).Width = 800
    DataGrid1.Columns(6).Visible = False
    DataGrid1.Refresh
    rst_Tmp_Ping.MoveFirst
    '更新月凭证号显示
    Text1.Text = Str(rst_Tmp_Ping!月凭证号)
    
    
    MaskEdBox1.Text = Val(rst_Tmp_Ping!原始凭证数) '更改原始凭证个数的显示

    '更新分析科目 DataGrid2
    iPzid = 0
    If rst_Tmp_Ping.RecordCount = 0 Then
        MsgBox "凭证记录集为空，共0个记录,出错"
        Exit Sub
    Else
        If Not IsNull(rst_Tmp_Ping!ID) Then iPzid = rst_Tmp_Ping!ID
    End If
    sqlFxtemp = "select * from tempFX where PZid = " & Str(iPzid)
    If rstFxTemp.State = adStateOpen Then
        rstFxTemp.Close
    End If
    rstFxTemp.Open sqlFxtemp, pubConn, adOpenDynamic, adLockOptimistic
    Set DataGrid2.DataSource = rstFxTemp
    DataGrid2.Refresh
    
    '更新月凭证号显示
    Text1.Text = Str(rst_Tmp_Ping!月凭证号)
    isSavedCurrent = True
    cmdPre.Enabled = True
End Sub

Private Sub cmdPre_Click()
    Dim iRecCur As Integer
    Dim iMaxPZid As Long
    Dim strSql As String
    Dim rstTemp As New ADODB.Recordset
    Dim iPzid As Long '分析科目对应的凭证中的记录号（不是凭证号）
    If Not isSavedCurrent Then
        MsgBox "当前凭帐未保存，请先保存，再查看上一个凭证"
        Exit Sub
    End If
    iRecCur = Val(txtNumber.Text) - 1
    If iRecCur = 1 Then
        cmdPre.Enabled = False '记录号为1，将命令按钮变灰
    End If
    
    txtNumber.Text = Str(iRecCur)  '更改显示凭证号文本框的值
    
    pubConn.Execute "delete * from tempPingZheng"
    pubConn.Execute "delete * from tempfx"
    strSql = "insert into tempPingZheng select 摘要,科目,科目编号,借方金额,贷方金额,记录号,id,原始凭证数,月凭证号   from PingZheng where 凭证号 = " & iRecCur
    pubConn.Execute strSql
    strSql = "insert into tempFx(科目,科目编号,记录号,金额,pzid) select 科目,编号,记录号,金额,pzid from PingZhengfx where 凭证号 =" & iRecCur
    pubConn.Execute strSql
    rstTemp.Open "select 日期  from PingZheng where" & Str(iRecCur), pubConn
    If rstTemp.RecordCount = 0 Then
        MsgBox "本凭证号无记录"
        Exit Sub
    End If
    If IsNull(rstTemp!日期) Then
             MsgBox "日期为空，数据出错"
             Exit Sub
         Else
            DTPicker1.Value = rstTemp!日期   '更改日期显示，显示当前凭证日期
    End If
    rstTemp.Close
    '更新datagrid1中显示凭证科目的内容
    If rst_Tmp_Ping.State = adStateOpen Then
        rst_Tmp_Ping.Close
    End If
    rst_Tmp_Ping.Open "select * from tempPingZheng order by id", pubConn, adOpenDynamic, adLockOptimistic
     
    Set DataGrid1.DataSource = rst_Tmp_Ping
    DataGrid1.Columns(0).Visible = False
    DataGrid1.Columns(1).Width = 1400
    DataGrid1.Columns(3).Width = 800
    DataGrid1.Columns(4).Width = 800
    DataGrid1.Columns(5).Width = 800
    DataGrid1.Columns(6).Visible = False
    DataGrid1.Refresh
    rst_Tmp_Ping.MoveFirst
    
    '更新月凭证号显示
    Text1.Text = Str(rst_Tmp_Ping!月凭证号)
    
    MaskEdBox1.Text = Str(rst_Tmp_Ping!原始凭证数) '更改原始凭证个数的显示
    
    '更新分析科目 DataGrid2
    iPzid = 0
    If rst_Tmp_Ping.RecordCount = 0 Then
        MsgBox "凭证记录集为空，共0个记录,出错"
        Exit Sub
    Else
        If Not IsNull(rst_Tmp_Ping!ID) Then iPzid = rst_Tmp_Ping!ID
    End If
    
    sqlFxtemp = "select * from tempFX where PZid = " & iPzid
    If rstFxTemp.State = adStateOpen Then
        rstFxTemp.Close
    End If
    rstFxTemp.Open sqlFxtemp, pubConn, adOpenDynamic, adLockOptimistic
    Set DataGrid2.DataSource = rstFxTemp
    DataGrid2.Refresh
    
    isSavedCurrent = True
    cmdNext.Enabled = True
    
    rstTemp.Open "select max(凭证号) as idx from PingZheng", pubConn
    If IsNull(rstTemp!idx) Then
             iMaxPZid = 0
             cmdNext.Enabled = False
    Else
           iMaxPZid = rstTemp!idx
            If iMaxPZid <= iRecCur Then cmdNext.Enabled = False
    End If
    rstTemp.Close

End Sub

Private Sub cmdPrint_Click()
    Dim mobjExcel As Excel.Application
    Dim mobjworkbook As Excel.Workbook
    Dim xlsheet As Excel.Worksheet
    Dim rstPingZheng As New ADODB.Recordset
    Dim strDestination, strSource As String
    Dim iLine As Integer
    iLine = 5
    Dim iCol As Integer
    Dim curTemp As Currency
    '‘Screen.MousePointer = vbHourglass
    strSource = App.Path & "\PingZheng.xls"
    strDestination = App.Path & "\2.xls"
    If Dir(strDestination) <> "" Then Kill strDestination
    FileCopy strSource, strDestination
    Set mobjExcel = New Excel.Application
    Set mobjExcel = CreateObject("Excel.Application")
    mobjExcel.Visible = True
    Set mobjworkbook = mobjExcel.Workbooks.Open(strDestination)
    Set xlsheet = mobjworkbook.Worksheets(1)
    rstPingZheng.Open "select * from PingZheng  where 凭证号 = " & txtNumber.Text, pubConn, adOpenDynamic, adLockOptimistic
    rstPingZheng.MoveFirst
    '填充凭证数据
    mobjExcel.ActiveSheet.Cells(1, 6).Value = "总字第" & txtNumber.Text & "号"
    mobjExcel.ActiveSheet.Cells(2, 6).Value = "第" & Text1.Text & "号"
    mobjExcel.ActiveSheet.Cells(5, 1).Value = rstPingZheng!摘要
    mobjExcel.ActiveSheet.Cells(2, 1).Value = "日期：" & CStr(rstPingZheng!日期)
    mobjExcel.ActiveSheet.Cells(6, 7).Value = rstPingZheng!原始凭证数
    While Not rstPingZheng.EOF
        If rstPingZheng!借方金额 > 0 Then
          iCol = 2
          curTemp = rstPingZheng!借方金额
          Else
          iCol = 4
          curTemp = rstPingZheng!贷方金额
          End If
        mobjExcel.ActiveSheet.Cells(iLine, iCol).Value = strFindMainKemu(rstPingZheng!科目)
        mobjExcel.ActiveSheet.Cells(iLine, iCol + 1).Value = strFindSubKemu(rstPingZheng!科目)
        mobjExcel.ActiveSheet.Cells(iLine, 6).Value = curTemp
        iLine = iLine + 1
        rstPingZheng.MoveNext
    Wend
     '打印预览
     xlsheet.PrintPreview
    mobjworkbook.Save
    mobjExcel.Quit
    isPrinted = True
    'Screen.MousePointer = vbDefault
End Sub
Private Sub cmdSave_Click()
     '保存按钮,保存记凭帐及分析科目
     '保存分析科目，不能避免重复保存，需要调整
      Dim rstPingZheng As New ADODB.Recordset '记帐凭证中的记录集
      Dim rstPZfxtmp As New ADODB.Recordset  '临时分析科目记录集
      Dim rstPZfx As New ADODB.Recordset  '分析科目记录集
      Dim i As Integer   '记帐凭证中的记录号
      Dim j As Integer  '分析科目中的记录号