frmfi_zzpzset.frm

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

            .ColWidth(COL_DEPARTMENT) = 2150
        Else
            .ColWidth(COL_ITEM) = 0
            .ColWidth(COL_DEPARTMENT) = 0
        End If
        .ColWidth(COL_DIRECT) = 800
        .ColWidth(COL_FORMULA) = 8360
        For j = 0 To .Cols - 1          '表头文字居中(此操作触发了 mFg_LeaveCell 事件)
            .row = 0
            .col = j
            .CellAlignment = 4
        Next j
        .Redraw = True
    End With
End Sub

Private Sub FillCbo()       '填充各凭证设置
        Dim rstPzSet As New ADODB.Recordset
        Dim sOldID As String
        Dim i As Integer
        ReDim sPzlb(0)      '默认数值
        sOldID = ""
        rstPzSet.CursorLocation = adUseClient
        rstPzSet.Open "select id,czzsm,cpzlb from tzw_zzpzset" & glo.sOperateYear & "  where cPzType='" & m_sPzType & "' order by id", glo.cnnMain, adOpenStatic, adLockReadOnly
        
        If rstPzSet.RecordCount > 0 Then
           ReDim sPzlb(rstPzSet.RecordCount)
           i = 1
           rstPzSet.MoveFirst
           While Not rstPzSet.EOF
                If sOldID <> Trim(rstPzSet.Fields("id").value) Then
                    cboZzXh.AddItem Trim(rstPzSet.Fields("id").value)           '成对
                    cboZzsm.AddItem Trim(rstPzSet.Fields("czzsm").value)
                    cboZzXh.ItemData(cboZzXh.NewIndex) = i
                    sPzlb(i) = Trim(rstPzSet.Fields("cpzlb").value)
                    sOldID = Trim(rstPzSet.Fields("id").value)           '上一个ＩＤ号
                    i = i + 1
                End If
                rstPzSet.MoveNext
           Wend
        
                cboZzXh.ListIndex = 0
                cboZzsm.ListIndex = 0
       End If
        
End Sub

Private Sub FillOther()            '填充凭证分录
        Dim i As Integer
        Dim rstTmp As New ADODB.Recordset
        Dim iRR As Integer
        
        rstTmp.CursorLocation = adUseClient
        rstTmp.Open "select * from tzw_zzpzset" & glo.sOperateYear & " where id='" & _
                    Trim(cboZzXh.text) & "'  and cpztype='" & m_sPzType & "' order by sijlhm", glo.cnnMain, adOpenStatic, adLockReadOnly
        lbPzlb.Caption = sPzlb(cboZzXh.ItemData(cboZzXh.ListIndex))
        cboZzsm.ListIndex = cboZzXh.ListIndex
        
        If rstTmp.RecordCount > 0 Then
            mFg.Rows = rstTmp.RecordCount + 1
            rstTmp.MoveFirst
            iRR = 1
            While Not rstTmp.EOF                  '摘要|>科目代码|>方向|>金额公式
                  mFg.TextMatrix(iRR, COL_ID) = CStr(iRR)
                  mFg.TextMatrix(iRR, COL_SUMMARY) = IIf(IsNull(rstTmp.Fields("czy").value), "", Trim(rstTmp.Fields("czy").value))
                  mFg.TextMatrix(iRR, COL_SUBJECT) = Trim(rstTmp.Fields("ckmdm").value) + "=" + GetKmmc(Trim(rstTmp.Fields("ckmdm").value))
                  mFg.TextMatrix(iRR, COL_ITEM) = FormatToString((rstTmp.Fields("xmdm").value)) + "=" + FormatToString((rstTmp.Fields("xmmc").value))
                  If mFg.TextMatrix(iRR, COL_ITEM) = "=" Then mFg.TextMatrix(iRR, COL_ITEM) = ""
                  mFg.TextMatrix(iRR, COL_DEPARTMENT) = FormatToString(rstTmp.Fields("bmdm").value) + "=" + FormatToString((rstTmp.Fields("bmmc").value))
                  If mFg.TextMatrix(iRR, COL_DEPARTMENT) = "=" Then mFg.TextMatrix(iRR, COL_DEPARTMENT) = ""
                  mFg.TextMatrix(iRR, COL_DIRECT) = Trim(rstTmp.Fields("cfx").value)
                  mFg.TextMatrix(iRR, COL_FORMULA) = Trim(rstTmp.Fields("cjegs").value)
                  rstTmp.MoveNext
                  iRR = iRR + 1
            Wend
       Else
           mFg.Rows = 1
           cmdHelp.Visible = False
           txtEdit.Visible = False
       End If
       
       If mFg.Rows > 1 Then
            With mFg
                 For i = 1 To .Rows - 1          '设可输入行高
                     .RowHeight(i) = 380
                 Next i
                 
                 .row = 1                        '设活动单元
                 .col = 0
             End With
      End If
       
End Sub

Private Sub Form_Unload(Cancel As Integer)
        Unload frmFI_ZzpzAdd
        Unload frmH_Summ
End Sub

Private Sub mFg_EnterCell()

            If mFg.Tag <> "" Then
               MsgBox mFg.Tag, vbExclamation, "提示"
               mFg.row = iOldRow
               mFg.col = iOldCol
               Exit Sub
            End If

End Sub

Private Sub mFg_GotFocus()
        With mFg
            If .row > 0 Then
                
                txtEdit.Move .Left + .CellLeft, .Top + .CellTop, .cellWidth, .cellHeight
                txtEdit.Visible = True
                txtEdit.text = GetCode(Trim(mFg.TextMatrix(.row, .col)))
                txtEdit.SelStart = 0
                txtEdit.SelLength = Len(txtEdit.text)
                txtEdit.Refresh

                '移动按钮到文本框的右下角（按钮的宽、高在设计时确定）
                cmdHelp.Move txtEdit.Left + txtEdit.Width - cmdHelp.Width, txtEdit.Top + txtEdit.Height - cmdHelp.Height
                cmdHelp.Visible = True
                
            End If
           
        End With
End Sub

Private Sub mFg_KeyUp(KeyCode As Integer, Shift As Integer)
   Call mFg_GotFocus
   txtEdit.SelStart = 0
   txtEdit.SelLength = Len(txtEdit.text)
   If mFg.Rows > 1 Then
     txtEdit.SetFocus
   End If
End Sub

Private Sub mFg_LeaveCell()
    Dim sErr As String
    mFg.Tag = ""         '提示信息
    If txtEdit.Visible = True And mFg.row > 0 Then
        iOldRow = mFg.row
        iOldCol = mFg.col
        If Trim(txtEdit.text) <> "" Then          '空隔先不考虑
            Select Case mFg.col
            Case COL_SUMMARY
                 If Len(Trim(txtEdit.text)) > 100 Then
                    mFg.Tag = "摘要长度不能超100！"
                    GoTo Err         '如果要当前编辑，可以去掉所有的 goto err 语句
                 End If
            Case COL_SUBJECT       '科目检查
                 If SqlStringValid(txtEdit.text) = False Then
                    mFg.Tag = "科目不能含有非法的字符！"
                    GoTo Err
                 End If
                 If Not CheckHave("tzw_km" & glo.sOperateYear, txtEdit, "kmdm", "kmmc", Trim(txtEdit.text), "IsEndKm=-1") Then
                    mFg.Tag = "科目代码或名称不存在，或者科目不是明细科目！"
                    GoTo Err
                 End If
            Case COL_ITEM
                 If SqlStringValid(txtEdit.text) = False Then
                    mFg.Tag = "项目不能含有非法的字符！"
                    GoTo Err
                 End If
                 If Not CheckHave("tzw_Item" & glo.sOperateYear, txtEdit, "cCode", "cName", Trim(txtEdit.text)) Then
                    mFg.Tag = "项目代码或名称不存在！"
                    GoTo Err
                 End If
            Case COL_DEPARTMENT
                 If SqlStringValid(txtEdit.text) = False Then
                    mFg.Tag = "部门不能含有非法的字符！"
                    GoTo Err
                 End If
                 If Not CheckHave("tUsu_Department" & glo.sOperateYear, txtEdit, "CDepCode", "CDepName", Trim(txtEdit.text), "BDepEnd=-1") Then
                    mFg.Tag = "部门代码或名称不存在！，或者不是末级部门！"
                    GoTo Err
                 End If
            Case COL_DIRECT       '方向
                 If Trim(txtEdit.text) <> "借" Then
                    If Trim(txtEdit.text) <> "贷" Then
                       mFg.Tag = "方向只能为借或贷！"
                       GoTo Err
                    End If
                 End If
                 
            Case COL_FORMULA       '公式检查
                 If Len(Trim(txtEdit.text)) > 200 Then
                    mFg.Tag = "公式长度不能超过200！"
                    GoTo Err
                 End If
                 
                 sErr = CheckUserFormulaErr(Trim(txtEdit.text))
                 If sErr <> "" Then
                    mFg.Tag = sErr
                    GoTo Err
                 End If
                 
            End Select
      End If
        mFg.TextMatrix(mFg.row, mFg.col) = Trim(txtEdit.text)
    End If
    
Err:    txtEdit.Visible = False          '当得到焦点时又显示
        cmdHelp.Visible = False
End Sub

Private Function CheckUserFormulaErr(sFormula As String)        '检查公式正确
        Dim result As Variant
        
        CheckUserFormulaErr = ""
        cLlzzpz.SetCellString 0, 0, cLlzzpz.GetCurSheet, ""
        cLlzzpz.Redraw
        cLlzzpz.MoveToCell 0, 0
        cLlzzpz.Clear 2
        
        bFormulaErr = False                    '无出错
        cLlzzpz.SetFormula 0, 0, cLlzzpz.GetCurSheet, sFormula
        
        cLlzzpz.CalculateAll
        result = cLlzzpz.GetCellDouble(0, 0, cLlzzpz.GetCurSheet)
        
        If result <> "" Then
            If bFormulaErr = True Then
               CheckUserFormulaErr = "公式定义不正确！"
            End If
        Else
           CheckUserFormulaErr = "公式定义不正确！"
        End If
        
End Function

'  yang     检查记录是否被使用    把名称变成代码
Private Function CheckHave(newTable As String, cTxt As TextBox, sDm As String, sMc As String, newVal As Variant, Optional ByVal sWhere As String) As Boolean

    Dim rstTmp As New ADODB.Recordset
    
    rstTmp.CursorLocation = adUseClient
    If sWhere <> "" Then
        sWhere = " and " + sWhere
    End If
    rstTmp.Open "select * from " & newTable & " where (rtrim(" & sDm & ")='" & newVal & "' or rtrim(" & sMc & ")='" & newVal & "') " + sWhere, glo.cnnMain, adOpenStatic, adLockReadOnly
    If rstTmp.RecordCount > 0 Then
       cTxt = Trim(rstTmp.Fields(sDm).value) + "=" + FormatToString(rstTmp.Fields(sMc).value)
       CheckHave = True
    Else
       CheckHave = False
    End If
    

End Function

Private Sub mFg_RowColChange()
        If bStartPrint = False Then
                Call mFg_GotFocus
        End If
End Sub

Private Sub mfg_Scroll()
With mFg
    If .ColIsVisible(.col) And .ColPos(.col) + .ColWidth(.col) <= .Width And .RowPos(.row) + .RowHeight(.row) <= .Height And .RowIsVisible(.row) Then
        txtEdit.Move .Left + .CellLeft, .Top + .CellTop, .cellWidth, .cellHeight
        cmdHelp.Move txtEdit.Left + txtEdit.Width - cmdHelp.Width, txtEdit.Top + txtEdit.Height - cmdHelp.Height
    Else
        mFg_LeaveCell
    End If
End With
End Sub

Private Sub mnuAdd_Click()
        Call MainOption("add")
End Sub

Private Sub mnuAddRow_Click()
        Call MainOption("addrow")
End Sub

Private Sub mnuClose_Click()
        Unload Me
End Sub

Private Sub mnuDelete_Click()
     Call MainOption("delete")
End Sub

Private Sub mnuDelRow_Click()
        Call MainOption("delrow")
End Sub

Private Sub mnuHelp_Click()
        SendKeys "{f1}"
End Sub

Private Sub mnuPreview_Click()
     If Printers.Count = 0 Then
        MsgBox "未安装打印。", vbInformation
        Exit Sub
     End If
     Call MainOption("preview")
End Sub

Private Sub mnuPrint_Click()
     If Printers.Count = 0 Then
        MsgBox "未安装打印。", vbInformation
        Exit Sub
     End If
     Call MainOption("print")
End Sub


Private Sub mnuSave_Click()
        Call MainOption("save")