frmac_generalselectprint.frm

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

   '将CELL不可见，防止清除CELL控件内容时屏幕闪烁；
    Cllr.ResetContent
    Cllr.SetDefaultFont Cllr.FindFontIndex("宋体", 1), 10
    Cllr.WorkbookReadonly = True                                '表格只读
    Cllr.AllowSizeColInGrid = True

    m_bFormLoad = False
    Screen.MousePointer = vbDefault
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    Cllr.Width = Me.ScaleWidth - 100
    Cllr.Height = Me.ScaleHeight - 200
End Sub

Private Sub cmdCancel_Click()
    Me.Hide
    Unload Me
End Sub

Private Sub txtJcTo_KeyPress(KeyAscii As Integer)
   If KeyAscii = 13 Then SendKeys "{tab}"
End Sub



Private Sub txtPageStart_KeyPress(KeyAscii As Integer)
 If KeyAscii = 13 Then
        SendKeys "{tab}"
    Else
        KeyAscii = IntegerEnabled(KeyAscii)
    End If
End Sub

Private Sub txtSubjectend_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim CtrlDown As Boolean
    
    CtrlDown = (Shift And vbCtrlMask) > 0
    If KeyCode = vbKeyF And CtrlDown Then
        Call cmdSubjectEnd_Click
    End If
End Sub

Private Sub txtSubjectEnd_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then SendKeys "{tab}"
End Sub

Private Sub txtSubjectstart_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim CtrlDown As Boolean
    
    CtrlDown = (Shift And vbCtrlMask) > 0
    If KeyCode = vbKeyF And CtrlDown Then
        Call cmdSubjectStart_Click
    End If
End Sub

Private Sub txtSubjectStart_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then SendKeys "{tab}"
End Sub

Private Function txt_kmcheck() As Boolean
     Dim iTemp As Integer
     Dim sSubjectStart As String
     Dim sSubjectEnd As String
     Dim sKmdm As String
     
     txt_kmcheck = False
     If Trim(txtSubjectStart.text) = "" Or Trim(txtSubjectEnd.text) = "" Then
          MsgBox "请输入起始和终止科目！", vbInformation
          Exit Function
     End If
     
     If Trim$("" & txtSubjectStart.text) <> "" Then
        iTemp = InStr(1, txtSubjectStart.text, "=")
        If iTemp <> 0 Then
           sKmdm = Left(Trim(txtSubjectStart.text), iTemp - 1)
'           If getKmJc(sKmdm) = 0 Then
              CSubject.Init sKmdm, glo.sOperateYear
'           Else
'              MsgBox "起始科目输入不正确,此输入只能为一级科目！", vbInformation
'              txtSubjectStart.SelStart = 0
'              txtSubjectStart.SelLength = Len(txtSubjectStart.text)
'              txtSubjectStart.SetFocus
'              Exit Function
'           End If
        Else
            sKmdm = Trim(txtSubjectStart.text)
'           If getKmJc(sKmdm) = 0 Then
               CSubject.Init Trim$("" & txtSubjectStart.text), glo.sOperateYear
'           Else
'              MsgBox "起始科目输入不正确,此输入只能为一级科目！", vbInformation
'              txtSubjectStart.SelStart = 0
'              txtSubjectStart.SelLength = Len(txtSubjectStart.text)
'              txtSubjectStart.SetFocus
'              Exit Function
'           End If
        End If
        If Not CSubject.SubjectIsExist Then
            MsgBox "起始科目输入不正确！", vbInformation
            txtSubjectStart.SelStart = 0
            txtSubjectStart.SelLength = Len(txtSubjectStart.text)
            txtSubjectStart.SetFocus
            Exit Function
        End If
        sSubjectStart = CSubject.SubjectCode
     Else
        sSubjectStart = ""
     End If
    
   '检查终止科目
    If Trim$("" & txtSubjectEnd.text) <> "" Then
        iTemp = InStr(1, txtSubjectEnd.text, "=")
        If iTemp <> 0 Then
           sKmdm = Left(Trim(txtSubjectEnd.text), iTemp - 1)
'           If getKmJc(sKmdm) = 0 Then
            CSubject.Init sKmdm, glo.sOperateYear
'          Else
'            MsgBox "终止科目输入不正确,此输入只能为一级科目！", vbInformation
'            txtSubjectEnd.SelStart = 0
'            txtSubjectEnd.SelLength = Len(txtSubjectEnd.text)
'            txtSubjectEnd.SetFocus
'          End If
        Else
            sKmdm = Trim(txtSubjectStart.text)
'           If getKmJc(sKmdm) = 0 Then
              CSubject.Init Trim$("" & txtSubjectEnd.text), glo.sOperateYear
'           Else
'
'              MsgBox "终止科目输入不正确,此输入只能为一级科目！", vbInformation
'              txtSubjectEnd.SelStart = 0
'              txtSubjectEnd.SelLength = Len(txtSubjectEnd.text)
'              txtSubjectEnd.SetFocus
'              Exit Function
'           End If
        End If
        If Not CSubject.SubjectIsExist Then
            MsgBox "终止科目输入不正确！", vbInformation
            txtSubjectEnd.SelStart = 0
            txtSubjectEnd.SelLength = Len(txtSubjectEnd.text)
            txtSubjectEnd.SetFocus
            Exit Function
        End If
        sSubjectEnd = CSubject.SubjectCode
     Else
        sSubjectEnd = ""
     End If
       
   '检查开始科目代码是否小于等于终止科目
     If sSubjectEnd <> "" Then
        If Trim(sSubjectStart > sSubjectEnd) Then
               MsgBox "起始科目编码要小于等于终止科目编码！", vbInformation
               txtSubjectStart.SetFocus
               txtSubjectStart.SelStart = 0
               txtSubjectStart.SelLength = Len(txtSubjectStart.text)
               Exit Function
         End If
     End If
     txt_kmcheck = True
End Function
Private Sub Kmmc_set()
   '设置科目代码数组
   
   Dim temp_code As String
   Dim i As Integer
   Dim j As Integer
   Dim k As Integer
   Dim iTemp As Integer
   Dim iLenStart As Integer
   Dim iLenEnd As Integer
   Dim sjcStart As Integer
   Dim sjcEnd As Integer
   Dim sTemp As String
   Dim sTempStart As String
   Dim sTempEnd As String
      
   '取科目代码
    j = 1
    iTemp = InStr(1, txtSubjectStart.text, "=")
    If iTemp <> 0 Then
       sKmCodeStart = Left$(Trim$("" & txtSubjectStart.text), iTemp - 1)
    Else
        sKmCodeStart = Trim$("" & txtSubjectStart.text)
    End If
    
    iTemp = InStr(1, txtSubjectEnd.text, "=")
    If iTemp <> 0 Then
        sKmCodeEnd = Left$(Trim$("" & txtSubjectEnd.text), iTemp - 1)
    Else
        sKmCodeEnd = Trim$("" & txtSubjectEnd.text)
    End If
   
   iLenStart = Len(sKmCodeStart)
   iLenEnd = Len(sKmCodeEnd)
   
 
    '判断开始和终止代码是否是同一科目下
    '是
    ReDim arySubDetail(0 To 0)
    iTemp = InStr(1, sKmCodeStart, glo.sSeparateSubject, vbTextCompare)
    If iTemp > 0 Then
        sTempStart = Mid(sKmCodeStart, 1, iTemp - 1)
    Else
        sTempStart = sKmCodeStart
    End If
    iTemp = InStr(1, sKmCodeEnd, glo.sSeparateSubject, vbTextCompare)
    If iTemp > 0 Then
        sTempEnd = Mid(sKmCodeEnd, 1, iTemp - 1)
    Else
        sTempEnd = sKmCodeEnd
    End If
    If InStr(1, sKmCodeEnd, sTempStart, vbTextCompare) = 1 Then
       Call GetDetailKm(sTempStart)
       If bDetailFlag Then
          For i = LBound(arySubject) To UBound(arySubject)
               If Left(arySubject(i).sSubjectCode, iLenStart) >= Trim(sKmCodeStart) And Left(arySubject(i).sSubjectCode, iLenEnd) <= Trim(sKmCodeEnd) Then
                  ReDim Preserve arySubDetail(UBound(arySubDetail) + 1)
                  arySubDetail(j).sSubjectCode = arySubject(i).sSubjectCode
                  arySubDetail(j).sSubjectName = arySubject(i).sSubjectName
                  j = j + 1
              End If
         Next i
       End If
     Else
     '不是同一级科目
         Call GetFKm(sTempStart, sTempEnd)
         For i = LBound(sFirstLevel) To UBound(sFirstLevel)
            sTemp = sFirstLevel(i).sSubjectCode
            Call GetDetailKm(sTemp)
            If bDetailFlag Then
                For k = LBound(arySubject) To UBound(arySubject)
                   If Left(arySubject(k).sSubjectCode, iLenStart) >= Trim(sKmCodeStart) And Left(arySubject(k).sSubjectCode, iLenEnd) <= Trim(sKmCodeEnd) Then
                          ReDim Preserve arySubDetail(UBound(arySubDetail) + 1)
                          arySubDetail(j).sSubjectCode = arySubject(k).sSubjectCode
                          arySubDetail(j).sSubjectName = arySubject(k).sSubjectName
                          j = j + 1
                    End If
                Next k
            End If
         Next i
   End If
End Sub

Public Sub udoPrint()
   Dim lTotalPages As Long, i As Long
   lTotalPages = Cllr.GetTotalSheets
    For i = 1 To lTotalPages

        Cllr.SetCurSheet i - 1
        Cllr.PrintSheet 0, i - 1
    Next i
End Sub
Private Sub uPreview()

    Cllr.PrintPreview 1, Cllr.GetCurSheet
      If Cllr.SaveFile(App.Path & "\CellFiles\General.cll", 1) = 0 Then
       MsgBox "CELL文件保存失败！", vbOKOnly
    End If
End Sub

Private Sub SetGridHead()
    Dim i As Integer
    Dim j As Integer
    
    usAccountType = "总账"
    
    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
        .SetCols COL_END + 2, Cllr.GetCurSheet                             '表格列数
 
        .SetSelectMode Cllr.GetCurSheet, 2                       '允许整行选择
        .SetFixedCol COL_START, COL_DAY             '设置不滚动列
        .SetFixedRow ROW_TITLE, ROW_HEAD2           '设置不滚动行
        '.DoSetPrintPara 1, 9, True                     '打印参数; 1 = 缩放比例, 9 = A4纸, true =纵向打印
        .ShowSideLabel 0, .GetCurSheet
        .ShowTopLabel 0, .GetCurSheet
        
    'Title
        '设置单元格中文本对齐方式; &H24=100100 表示水平中线方向对齐,垂直中线方向对齐
        .SetCellAlign COL_START, ROW_TITLE, .GetCurSheet, 32 + 4
        
        '设置指定单元格中文本的字体; 15号字体, 5=粗体加下划线, 黑体
        .SetCellFont COL_START, ROW_TITLE, .GetCurSheet, .FindFontIndex("黑体", 1)
        .SetCellFontSize COL_START, ROW_TITLE, .GetCurSheet, 19
        .SetCellFontStyle COL_START, ROW_TITLE, .GetCurSheet, 10
        
        '合并指定区域内的单元格
        .MergeCells COL_START, ROW_TITLE, COL_END, ROW_TITLE
        
        '设置指定单元格中字符串数据
        .SetCellString COL_START, ROW_TITLE, .GetCurSheet, m_sGenSubjectName & IIf(IsSyTitle = False, "总账", "明细账")
        
        '行高
'        .SetRowHeight 1, 40, ROW_TITLE, .GetCurSheet
        .SetRowHeight 1, 26, ROW_TITLE, .GetCurSheet

    'Comment
        .SetRowHeight 1, 23, ROW_SUBJCODE, .GetCurSheet
        .SetRowHeight 1, 23, ROW_SUBJNAME, .GetCurSheet
    'Comment
        .MergeCells COL_START, ROW_ACCOUNTFORMAT, COL_END, ROW_ACCOUNTFORMAT
        '如果是数量账或者外币账, 则设置数量单位和外币单位格
        If m_bAmount Or m_bForeign Then
            If m_bAmount And m_bForeign Then
                .MergeCells COL_START, ROW_SUBJCODE, COL_BALANCE_FOREIGN, ROW_SUBJCODE
                .MergeCells COL_BALANCE_MONEY, ROW_SUBJCODE, COL_END, ROW_SUBJCODE
                .SetCellFont COL_BALANCE_MONEY, ROW_SUBJCODE, .GetCurSheet, .FindFontIndex("楷体_GB2312", 1)
                .SetCellFontSize COL_BALANCE_MONEY, ROW_SUBJCODE, .GetCurSheet, 11
                .SetCellFontStyle COL_BALANCE_MONEY, ROW_SUBJCODE, .GetCurSheet, 0
                .SetCellAlign COL_BALANCE_MONEY, ROW_SUBJCODE, .GetCurSheet, 33
            Else
                .MergeCells COL_START, ROW_SUBJCODE, COL_END, ROW_SUBJCODE
            End If
            .MergeCells COL_START, ROW_SUBJNAME, COL_BALANCE_FOREIGN, ROW_SUBJNAME