frmac_bookresultprint.frm

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

    With rSt
        .Open "select kmdm,kmmc from tZW_km" & glo.sOperateYear & _
            " where IsRjz=-1  order by kmdm", _
                glo.cnnMain, adOpenStatic, adLockReadOnly
        If .RecordCount = 0 Then
            MsgBox "还没有任何日记账科目！", vbInformation
        Else
            cboSubjectStart.Clear
            cboSubjectEnd.Clear
            ReDim m_stemp(0 To .RecordCount - 1)
            Do Until .EOF
                cboSubjectStart.AddItem Trim$("" & .Fields("kmdm").value) & _
                                    "=" & Trim$("" & .Fields("kmmc").value)
                cboSubjectEnd.AddItem Trim$("" & .Fields("kmdm").value) & _
                        "=" & Trim$("" & .Fields("kmmc").value)
                m_stemp(i) = Trim$("" & .Fields("kmdm").value) & _
                        "=" & Trim$("" & .Fields("kmmc").value)
                 i = i + 1
                .MoveNext
            Loop
        End If
        .Close
    End With
    Set rSt = Nothing
    cboSubjectStart.ListIndex = -1
    cboSubjectEnd.ListIndex = -1
    
    bpzFlag = False
    m_bFormLoad = True
    m_bExistRecord = True
'    Set CSubject = New clsSubject
    Set rstTemp = New ADODB.Recordset
    rstTemp.CursorLocation = adUseClient
    sSQL = "SELECT * FROM tSYS_SubSysUsed WHERE AccountID = '" & glo.sAccountID & _
            "' AND SubSysID = '" & gloSys.sSubSysId & "'"
    rstTemp.Open sSQL, gloSys.cnnSYS, adOpenStatic, adLockReadOnly
    With rstTemp
        If .RecordCount > 0 Then
            '如果当前注册年份大于结账年, 则查询最小月份为一月份、最大月份为一月份；
            If Val(glo.sOperateYear) > Val(.Fields("ModiYear").value) Then
                m_sMonthFrom = 0
                m_sMaxEndMonth = 1
            '否则如果注册年份等于结账年份, 则查询最小月份为
                                            '(如果注册年份等于子系统启用年份, 则等于子系统启用月份;
                                            '否则等于一月份);
                                            '最大月份等于结账月+1
            ElseIf Val(glo.sOperateYear) = Val(.Fields("ModiYear").value) Then
                m_sMonthFrom = IIf(Val(glo.sOperateYear) = Val(.Fields("BeginYear").value), _
                                    .Fields("BeginMonth").value - 1, 0)
                m_sMaxEndMonth = .Fields("ModiMonth").value + 1
            '否则查询最小月份为(如果注册年份等于
                                            '(如果注册年份等于子系统启用年份, 则等于子系统启用月份;
                                            '否则等于一月份);
                                            '最大月份等于12
            Else
                m_sMonthFrom = IIf(Val(glo.sOperateYear) = Val(.Fields("BeginYear").value), _
                                    .Fields("BeginMonth").value - 1, 0)
                m_sMaxEndMonth = 12
            End If
        End If
        .Close
    End With
    
    '从凭证表中查找已记账凭证的记录个数，条件kjqj等于最大查询结束月,并且修改标志为2
    '如果不存在, 则最大查询结束月等于最大查询结束月-1
    sSQL = "SELECT COUNT(*) FROM tZW_Pzsj" & glo.sOperateYear & _
            " WHERE kjqj = " & m_sMaxEndMonth & _
            " AND xgbz = '2'"
    With rstTemp
        .Open sSQL, glo.cnnMain, adOpenStatic, adLockReadOnly
        If .Fields(0).value = 0 Then
            If m_sMaxEndMonth > m_sMonthTo Then
                m_sMaxEndMonth = m_sMaxEndMonth - 1
            End If
        End If
        .Close
    End With
    
    '查询起始月从子系统启用月份到12月份
    For i = m_sMonthFrom + 1 To 12
        cboMonthFrom.AddItem glo.sOperateYear & "." & i
    Next i
    
    '查询截止月从子系统启用月份到12月份
    For i = m_sMonthFrom + 1 To 12
        cboMonthTo.AddItem glo.sOperateYear & "." & i
    Next i
    
    '选中的查询起始月等于当前注册月
    cboMonthFrom.ListIndex = Month(glo.sOperateDate) - m_sMonthFrom - 1
    
    '设置账页格式
    
     cboAccountFormat.AddItem "金额式"
     cboAccountFormat.AddItem "数量金额式"
     cboAccountFormat.AddItem "外币金额式"
     cboAccountFormat.AddItem "数量外币式"
     cboAccountFormat.ListIndex = 0
     If cboAccountFormat.ListIndex <> -1 Then
          usAccountFormat = cboAccountFormat.text
     Else
          usAccountFormat = ""
     End If
              
    Me.Caption = "日记账查询"
    usAccountType = "日记账"
    usAccountFormat = "金额式"
    Select Case usAccountFormat
        Case "金额式"
            m_sDefaultColWidth = COLWIDTH_MONEY
        Case "数量金额式"
            m_sDefaultColWidth = COLWIDTH_AMOUNT
        Case "外币金额式"
            m_sDefaultColWidth = COLWIDTH_FOREIGN
        Case "数量外币式"
            m_sDefaultColWidth = COLWIDTH_AMOUNT_FOREIGN
    End Select
    '求出各列的宽度
'    m_iColWidth = GetColWidth(usAccountType, usAccountFormat, m_sDefaultColWidth)
    m_iColWidth = ToIntegerArray(m_sDefaultColWidth)
    m_iColWidthTemp = m_iColWidth
    

    With Cllr
        .Login "南京伊康计算机工程公司", "11010504", "0060-1733-7722-3004"
        If .OpenFile(App.Path & "\CellFiles\Book.cll", "") = -1 Then
            MsgBox "CELL文件不存在！", vbOKOnly
        End If
   
      '将CELL不可见，防止清除CELL控件内容时屏幕闪烁；

       .ResetContent
       .SetCols COL_END + 2, 0
       .SetRows ROW_GRID_START + ROWS_PAGE, 0
       .SetDefaultFont .FindFontIndex("宋体", 1), 10
       .WorkbookReadonly = True
       .AllowSizeColInGrid = True

    End With

    m_bFormLoad = False
    Screen.MousePointer = vbDefault
End Sub

'账页格式被改变时触发
Private Sub cboAccountFormat_Click()
    Dim sOldAccountFormat As String     '账页原先格式
    
    If Not m_bFormLoad Then
        sOldAccountFormat = usAccountFormat
        usAccountFormat = cboAccountFormat.List(cboAccountFormat.ListIndex)
'        If IsColChange(Me.cllR, m_iColWidth) = True Then
'            If MsgBox(sOldAccountFormat & "账簿格式已经改变，是否保存？", vbQuestion + vbYesNo + vbDefaultButton2) = vbYes Then
'                Call SaveColChange(m_iColWidth, usAccountType, sOldAccountFormat)
'            End If
'        End If
        Select Case usAccountFormat
            Case "金额式"
                m_sDefaultColWidth = COLWIDTH_MONEY
            Case "数量金额式"
                m_sDefaultColWidth = COLWIDTH_AMOUNT
            Case "外币金额式"
                m_sDefaultColWidth = COLWIDTH_FOREIGN
            Case "数量外币式"
                m_sDefaultColWidth = COLWIDTH_AMOUNT_FOREIGN
        End Select
        'm_iColWidth = GetColWidth(usAccountType, usAccountFormat, m_sDefaultColWidth)
        m_iColWidth = ToIntegerArray(m_sDefaultColWidth)
        m_iColWidthTemp = m_iColWidth
        
        Select Case usAccountFormat
            Case "金额式"
                Call DoRedrawCellHead(m_iColWidth, COL_DEBIT_MONEY, COL_DEBIT_MONEY, _
                        COL_CREDIT_MONEY, COL_CREDIT_MONEY, COL_BALANCE_MONEY, COL_BALANCE_MONEY, _
                        ROW_HEAD1, ROW_HEAD2)
            Case "数量金额式"
                Call DoRedrawCellHead(m_iColWidth, COL_DEBIT_AMOUNT, COL_DEBIT_MONEY, _
                        COL_CREDIT_AMOUNT, COL_CREDIT_MONEY, COL_BALANCE_AMOUNT, COL_BALANCE_MONEY, _
                        ROW_HEAD1, ROW_HEAD1)
            Case "外币金额式"
                Call DoRedrawCellHead(m_iColWidth, COL_DEBIT_FOREIGN, COL_DEBIT_MONEY, _
                        COL_CREDIT_FOREIGN, COL_CREDIT_MONEY, COL_BALANCE_FOREIGN, COL_BALANCE_MONEY, _
                        ROW_HEAD1, ROW_HEAD1)
            Case "数量外币式"
                Call DoRedrawCellHead(m_iColWidth, COL_DEBIT_AMOUNT, COL_DEBIT_MONEY, _
                        COL_CREDIT_AMOUNT, COL_CREDIT_MONEY, COL_BALANCE_AMOUNT, COL_BALANCE_MONEY, _
                        ROW_HEAD1, ROW_HEAD1)
        End Select
 
    End If
End Sub

'根据选择的账页格式重画表格的页头
Private Sub DoRedrawCellHead(ByVal iColWidth As Variant, _
                            ByVal iCol_Debit_Start As Integer, ByVal iCol_Debit_End As Integer, _
                            ByVal iCol_Credit_Start As Integer, ByVal iCol_Credit_End As Integer, _
                            ByVal iCol_Balance_Start As Integer, ByVal iCol_balance_End As Integer, _
                            ByVal iRow_Start As Integer, ByVal iRow_End As Integer)
    Dim iTotalPages As Integer
    Dim lCurrentPage As Long
    Dim i As Integer
    Dim j As Integer
    
    With Cllr
        iTotalPages = .GetTotalSheets
        lCurrentPage = .GetCurSheet
        For i = 0 To iTotalPages
            .SetCurSheet i
            For j = LBound(iColWidth) To UBound(iColWidth)
                .SetColWidth 1, iColWidth(j), j, i
            Next j
            
            .MergeCells iCol_Debit_Start, iRow_Start, iCol_Debit_End, iRow_End
            .MergeCells iCol_Credit_Start, iRow_Start, iCol_Credit_End, iRow_End
            .MergeCells iCol_Balance_Start, iRow_Start, iCol_balance_End, iRow_End
            
            .SetCellString iCol_Debit_Start, ROW_HEAD1, i, "借方"
            .SetCellString iCol_Credit_Start, ROW_HEAD1, i, "贷方"
            .SetCellString iCol_Balance_Start, ROW_HEAD1, i, "余额"
            .SetCellString COL_DEBIT_AMOUNT, ROW_HEAD2, i, "数量"
            .SetCellString COL_DEBIT_FOREIGN, ROW_HEAD2, i, "外币"
            .SetCellString COL_DEBIT_MONEY, ROW_HEAD2, i, "金额"
            .SetCellString COL_CREDIT_AMOUNT, ROW_HEAD2, i, "数量"
            .SetCellString COL_CREDIT_FOREIGN, ROW_HEAD2, i, "外币"
            .SetCellString COL_CREDIT_MONEY, ROW_HEAD2, i, "金额"
            .SetCellString COL_BALANCE_AMOUNT, ROW_HEAD2, i, "数量"
            .SetCellString COL_BALANCE_FOREIGN, ROW_HEAD2, i, "外币"
            .SetCellString COL_BALANCE_MONEY, ROW_HEAD2, i, "金额"
        Next i
        .SetCurSheet lCurrentPage
    End With
End Sub

'向表格中追加一行
Private Sub AppendOneRow(ByVal i As Long, _
        ByVal lSerial As Long, ByVal iMonth As Integer, ByVal iDay As Integer, _
        ByVal sType As String, ByVal sNumber As String, ByVal sBill As String, _
        ByVal sSummary As String, ByVal dUnit_Price As Double, ByVal dExchange_Rate As Double, _
        ByVal sDirection As String, _
        ByVal dBalance_Amount As Double, ByVal dBalance_Foreign As Double, _
        ByVal dBalance_Money As Double, ByVal sMan As String, _
        Optional ByVal dDebit_Amount As Double, Optional ByVal dDebit_Foreign As Double, _
        Optional ByVal dDebit_Money As Double, Optional ByVal dCredit_Amount As Double, _
        Optional ByVal dCredit_Foreign As Double, Optional ByVal dCredit_Money As Double)
        
    With Cllr
        .SetCellString COL_SERIAL, i, .GetCurSheet, lSerial
        .SetCellString COL_MONTH, i, .GetCurSheet, IIf(iMonth = 0, "", iMonth)
        .SetCellString COL_DAY, i, .GetCurSheet, IIf(iDay = 0, "", iDay)
        .SetCellString COL_TYPE, i, .GetCurSheet, sType
        .SetCellString COL_NUMBER, i, .GetCurSheet, sNumber
        .SetCellString COL_BILL, i, .GetCurSheet, sBill
        .SetCellString COL_SUMMARY, i, .GetCurSheet, sSummary
        If Abs(dUnit_Price) > 0.0001 Then
        .SetCellDouble COL_UNIT_PRICE, i, .GetCurSheet, dUnit_Price
    End If
    If Abs(dExchange_Rate) > 0.0001 Then
        .SetCellDouble COL_EXCHANGE_RATE, i, .GetCurSheet, dExchange_Rate
    End If
    If Abs(dDebit_Amount) > 0.0001 Then
        .SetCellDouble COL_DEBIT_AMOUNT, i, .GetCurSheet, dDebit_Amount
    End If
    If Abs(dDebit_Foreign) > 0.0001 Then
        .SetCellDouble COL_DEBIT_FOREIGN, i, .GetCurSheet, dDebit_Foreign
    End If
    If Abs(dDebit_Money) > 0.0001 Then
        .SetCellDouble COL_DEBIT_MONEY, i, .GetCurSheet, dDebit_Money
    End If
    If Abs(dCredit_Amount) > 0.0001 Then
        .SetCellDouble COL_CREDIT_AMOUNT, i, .GetCurSheet, dCredit_Amount
    End If
    If Abs(dCredit_Foreign) > 0.0001 Then
        .SetCellDouble COL_CREDIT_FOREIGN, i, .GetCurSheet, dCredit_Foreign
    End If
    If Abs(dCredit_Money) > 0.0001 Then
        .SetCellDouble COL_CREDIT_MONEY, i, .GetCurSheet, dCredit_Money
    End If
        .SetCellString COL_DIRECTION, i, .GetCurSheet, sDirection
    If Abs(dBalance_Amount) > 0.0001 Then
        .SetCellDouble COL_BALANCE_AMOUNT, i, .GetCurSheet, dBalance_Amount
    End If
    If Abs(dBalance_Foreign) > 0.0001 Then
        .SetCellDouble COL_BALANCE_FOREIGN, i, .GetCurSheet, dBalance_Foreign
    End If
    If Abs(dBalance_Money) > 0.0001 Then
        .SetCellDouble COL_BALANCE_MONEY, i, .GetCurSheet, dBalance_Money
    End If
        .SetCellString COL_MAN, i, .GetCurSheet, sMan
    End With
    
End Sub
'初始化本日合计、本月合计、本期累计、过次变量
Private Sub InitVariant()

    brhjJ = 0
    brhjJSL = 0
    brhjJWB = 0
    brhjD = 0
    brhjDSL = 0
    brhjDWB = 0
    
    byhjJ = 0
    byhjJSL = 0
    byhjJWB = 0
    byhjD = 0
    byhjDSL = 0
    byhjDWB = 0
    
    bnljJ = 0
    bnljJSL = 0
    bnljJWB = 0
    bnljD = 0
    bnljDSL = 0
    bnljDWB = 0
    
    gcJ = 0