frmin_pztempletdesign.frm

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

    End If
End Sub

Private Sub tbr_ButtonClick(ByVal Button As MSComctlLib.Button)
    Dim lPoint As Long
    Dim tempVal As Long
    Dim i As Integer
    
    Select Case Button.Key
        Case "Print"
            Call PrintAll("PRINT")
        Case "Preview"
            Call PrintAll("PREVIEW")
        Case "Save"
            If Valid Then
                Call SaveDesign
            End If
            
        Case "InsertRow"
            '取得插入点
            lPoint = m_aryRefer(mFg.Row)
            '如果插入点为空或者插入点以前含空行，则不允许插入
            If mFg.TextMatrix(mFg.Row, 0) = "" Then
                MsgBox "本行是空行，不需要插入。", vbInformation
            ElseIf NoEmptyVoucherRow(mFg.Row) Then
                MsgBox "插入处前面包含空行，不可以插入！", vbInformation
            Else
                '增大凭证数组，移动数组元素
                ReDim Preserve m_aryVoucher(UBound(m_aryVoucher) + 1)
                    '自插入点后的所有元素后移
                For i = UBound(m_aryVoucher) - 1 To lPoint Step -1
                    m_aryVoucher(i + 1) = m_aryVoucher(i)
                Next i
                    '初始插入记录
                m_aryVoucher(lPoint).SubjectCode = ""
                m_aryVoucher(lPoint).SubjectCodeOLD = ""
                m_aryVoucher(lPoint).SubjectName = ""
                m_aryVoucher(lPoint).Summary = ""
                txtEdit.text = ""
                '重填表格
                Call ReFillGrid(m_aryRefer(1))
                '改变滚动条
                tempVal = UBound(m_aryVoucher) - VOUCHER_VIEWROWS
                m_bManualScroll = True
                vSb.Min = 0
                vSb.Max = IIf(tempVal > 0, tempVal, 0)
                vSb.SmallChange = 1
                vSb.LargeChange = VOUCHER_VIEWROWS
                m_bManualScroll = False
            End If
        
        Case "DeleteRow"
            If MsgBox("确实删除这条分录吗？", vbQuestion + vbYesNo) = vbYes Then
                '取得删除点
                lPoint = m_aryRefer(mFg.Row)
                '移动删除点后的记录
                For i = lPoint To UBound(m_aryVoucher) - 1
                    m_aryVoucher(i) = m_aryVoucher(i + 1)
                Next i
                ReDim Preserve m_aryVoucher(UBound(m_aryVoucher) - 1)
                '如果凭证记录个数少于可显示个数，则扩充为可显示个数
                If UBound(m_aryVoucher) < VOUCHER_VIEWROWS Then
                    ReDim Preserve m_aryVoucher(VOUCHER_VIEWROWS)
                Else
                    '改变滚动条
                    tempVal = UBound(m_aryVoucher) - VOUCHER_VIEWROWS
                    m_bManualScroll = True
                    vSb.Min = 0
                    vSb.value = IIf(vSb.Max < m_aryRefer(1) - 1, vSb.Max, m_aryRefer(1) - 1)
                    vSb.Max = IIf(tempVal > 0, tempVal, 0)
                    vSb.SmallChange = 1
                    vSb.LargeChange = VOUCHER_VIEWROWS
                    m_bManualScroll = False
                End If
                If vSb.Max = 0 Then m_aryRefer(1) = 1
                '重填
                Call ReFillGrid(m_aryRefer(1))
            End If
        
        Case "Help"
            Call ShowHelp
        Case "Quit"
            Unload Me
    End Select
End Sub




Private Sub mFg_GotFocus()

    On Error Resume Next        '窗体装入时可能出错
    
    With mFg
        '处于表格中“摘要”、“科目”单元时显示文本框及按钮
        If .Row > 0 And (.Col = 0 Or .Col = 1) Then
            '移动文本框
            txtEdit.Move .Left + .CellLeft, .Top + .CellTop, .cellWidth, .cellHeight
            txtEdit.Visible = True
            Select Case .Col
                Case 0          '处于“科目”列，将科目代码填入编辑文本框
                    txtEdit.text = m_aryVoucher(m_aryRefer(.Row)).SubjectCode
                Case 1          '处于“摘要”列，将摘要填入编辑文本框
                    txtEdit.text = .text    '或 m_aryVoucher(m_aryRefer(.Row)).Summary
            End Select
            '编辑文本框获得焦点
            txtEdit.SetFocus
            '移动按钮到文本框的右下角（按钮的宽、高在设计时确定）
            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_RowColChange()
    Call mFg_GotFocus
End Sub


Private Sub mFg_LeaveCell()
    Dim iLevel As Integer
    Dim i As Long
    Dim rstKm As ADODB.Recordset, rstKmTemp As ADODB.Recordset
    Dim sName As String
    Dim sCode As String
    Dim sCodePre As String, sNamePath As String
    
'----------------------------------------------------------
'算法：
'   如果文本框可见，执行：
'       保存表格离开的行(模块级变量);
'       将编辑框文本赋给表格;
'       对“科目”列，首先检查不能为空；然后判断是否已经改变。如果改变，则
'           1.查找是否存在(代码、名称、助记码均可);
'           2.是否末级科目;
'       确认是一个合法科目后，求它所处的级次并从而求得其科目名称路径，并判断是否有辅助信息
'----------------------------------------------------------
    Set rstKm = New ADODB.Recordset
    rstKm.CursorLocation = adUseClient
    Set rstKmTemp = New ADODB.Recordset
    rstKmTemp.CursorLocation = adUseClient
    
    If txtEdit.Visible Then
        
        With mFg
            m_iMfgOldRow = .Row
            '将编辑文本框内容填入表格
            .text = Trim$("" & txtEdit.text)
            Select Case .Col
                Case 0      '“科目”列
                    If .text = "" Then
                        '科目为空
                        .Tag = "科目不能为空！"
                    ElseIf SqlStringValid(.text) = False Then
                        .Tag = "科目不能含有非法的字符！"
                    ElseIf UBound(m_aryVoucher) < m_aryRefer(.Row) Then
                    
                    ElseIf m_aryVoucher(m_aryRefer(.Row)).SubjectCodeOLD = .text Then
                        If m_IsUseKmmc = True Then
                            .text = m_aryVoucher(m_aryRefer(.Row)).SubjectName
                        End If
                    Else
                        If rstKm.State = adStateOpen Then
                            rstKm.Close
                        End If
                        '查找科目代码或名称或助记码是否存在
                        rstKm.Open "select * from tZW_km" & glo.sOperateYear & _
                            " where kmdm='" & .text & "' or kmmc='" & _
                                   .text & "' or zjm='" & .text & "'", _
                                glo.cnnMain, adOpenStatic, adLockReadOnly
                        If rstKm.RecordCount = 0 Then                   '科目不存在
                            .Tag = "科目不存在！"
                        ElseIf Not rstKm.Fields("IsEndkm").value Then   '非末级科目
                            .Tag = "非末级科目！"
                        Else
                            .Tag = ""
                            sCode = rstKm.Fields("kmdm").value
                            'sName = GetSubjectFullPath(glo.sAccountID, rstKm.Fields("kmdm").Value)
                           '求当前科目级次
'                            For i = LBound(m_aryKmCodeLen) To UBound(m_aryKmCodeLen)
'                                If m_aryKmCodeLen(i) = Len(sCode) Then
'                                    iLevel = i
'                                    Exit For
'                                End If
'                            Next i
                            iLevel = GetKmJc(sCode) + 1
                            '求从一级科目到当前科目的名称路径
                            sNamePath = GetSubjectFullPath(glo.sAccountID, sCode)
                            '填入数组
                            m_aryVoucher(m_aryRefer(.Row)).SubjectCode = sCode
                            m_aryVoucher(m_aryRefer(.Row)).SubjectName = sNamePath
                            If m_IsUseKmmc = True Then
                               .text = sNamePath
                            Else
                               .text = sCode
                            End If
                            '将当前科目同时作为该分录的旧科目
                            m_aryVoucher(m_aryRefer(.Row)).SubjectCodeOLD = sCode
                        End If
                    End If

                Case 1      '“摘要”列
                    .Tag = ""
                    If m_aryRefer(.Row) <= UBound(m_aryVoucher) Then
                        m_aryVoucher(m_aryRefer(.Row)).Summary = .text
                    End If

            End Select
        End With
        
        '将文本框与按钮置为不可见（当另一单元获得焦点后，又将触发 mFg_GotFocus 事件，重新可见）
        txtEdit.Visible = False
        cmdHelp.Visible = False
    End If

End Sub


Private Sub mFg_EnterCell()
    Dim iTemp As Integer
    
    With mFg
        If .Tag <> "" Then
            Select Case True
                    '到达的行在原来所处行的上面，则如果原来所处行未输入任何金额，可以忽略
                Case m_iMfgOldRow > .Row
                    .Tag = ""
                Case Else
                    MsgBox .Tag, vbInformation
                    .Tag = ""
                    .Row = m_iMfgOldRow
                    .Col = 0
                    Exit Sub
            End Select
        End If
        '返回空行
        iTemp = NoEmptyVoucherRow(.Row)
        If iTemp > 0 Then
            .Row = iTemp
            .Col = 0
        End If
    End With

End Sub


'检查凭证输入中是否有空行
'   iAttempRow:试图到达的 mFg 行
'   返回值:0-没有空行,Other-空行行次
Private Function NoEmptyVoucherRow(ByVal iAttempRow As Integer) As Integer
    Dim i As Integer
    
    For i = 1 To iAttempRow - 1
        If mFg.TextMatrix(i, 0) = "" Then
            NoEmptyVoucherRow = i
            Exit Function
        End If
    Next i
    NoEmptyVoucherRow = 0

End Function





Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
    '上下翻页
    If KeyCode = 33 And Shift = 0 Then
        PageUp
    End If
    If KeyCode = 34 And Shift = 0 Then
        PageDown
    End If
    '名称与代码切换 F8
    If KeyCode = 119 And Shift = 0 Then
        m_IsUseKmmc = Not m_IsUseKmmc
        Call ReFillGrid(vSb.value + 1)
    End If
End Sub

Private Sub txtEdit_KeyPress(KeyAscii As Integer)
    
    Dim iTemp As Integer, tempVal As Integer
    
    Select Case True
    
        '按下回车键，如果处于第零列（“科目”），则跳到第一列（“摘要”）
        Case KeyAscii = 13 And mFg.Col = 0
            mFg.Col = 1
            mFg.SetFocus
            
        '处于“科目”列，按下回车键，则跳到 vaSpread
        Case KeyAscii = 13 And mFg.Col = 1
            With mFg
                
                If .Row = VOUCHER_VIEWROWS Then
                    '当处于末行单击回车时，可能要增加一行凭证记录
                    If m_aryRefer(.Row) = UBound(m_aryVoucher) Then                '如果最后一行也就是凭证记录的末行，则本操作应增加一条凭证记录
                        iTemp = NoEmptyVoucherRow(VOUCHER_VIEWROWS)
                        If iTemp <> 0 Then
                            .Row = iTemp
                        Else
                                '在 MsFlexGrid 中仍处于最后一行
                            .Row = VOUCHER_VIEWROWS
                                '增大凭证数据数组
                            ReDim Preserve m_aryVoucher(UBound(m_aryVoucher) + 1)
                                '移动表格中数据，重新指定参照她组
                            Call ReFillGrid(m_aryRefer(1) + 1)
                                '改变滚动条
                            tempVal = UBound(m_aryVoucher) - VOUCHER_VIEWROWS
                            m_bManualScroll = True
                            vSb.Min = 0
                            vSb.Max = IIf(tempVal > 0, tempVal, 0)
                            vSb.SmallChange = 1
                            vSb.LargeChange = VOUCHER_VIEWROWS
                            
                            m_bManualScroll = False
                        End If
                    
                    Else    '最后一行不是凭证记录的末行，则重填表格（所在行仍是最后一行）
                        Call ReFillGrid(m_aryRefer(1) + 1)
                    End If
                    
                Else
                    '转入下一行
                    .Row = .Row + 1
                End If
                
                ' MsFlexGrid 的第0列获得焦点
                .Col = 0
                .SetFocus
            End With
            
    End Select
    SqlStringValidText txtEdit.text, txtEdit.SelStart, txtEdit.SelLength, KeyAscii
End Sub


Private Sub txtEdit_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim tempVal As Integer
    '上下翻页
    If KeyCode = 33 And Shift = 0 Then
        PageUp
    End If
    If KeyCode = 34 And Shift = 0 Then
        PageDown
    End If
    '名称与代码切换 F8
    If KeyCode = 119 And Shift = 0 Then
        m_IsUseKmmc = Not m_IsUseKmmc
        Call ReFillGrid(vSb.value + 1)
    End If
'    If KeyCode = 13 And Shift = 0 Then
'        txtEdit_KeyPress (KeyCode)
'    End If
    With mFg
        Select Case KeyCode
            Case vbKeyLeft          '按下左箭头，如果处于表格第一列(“摘要”)且文本的最左，移到第零列(“科目”)
                If txtEdit.SelStart = 0 And .Col = 1 Then
                    .Col = 0        '该语句触发 mFg_LeaveCell 事件，完成了文本框值的赋入表格，并隐藏文本框
                    .SetFocus           '通过该方法触发 mFg_GotFocus 事件，使用文本框重新出现
                End If
                
            Case vbKeyRight         '按下右箭头
                If txtEdit.SelStart = Len(txtEdit.text) Then
                    Select Case .Col