frmin_ffdykm.frm

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

End If
If Me.Height > 1050 Then
    mfgLawless.Height = Me.Height - 1050
    Frame1.Top = mfgLawless.Height + mfgLawless.Top
End If
End Sub

Private Sub mfgLawless_Click()
   If txtFfdy.Visible Then
        With mfgLawless
            If .cellWidth > cmdKm.Width Then txtFfdy.Width = .cellWidth - cmdKm.Width
            txtFfdy.Height = .cellHeight
            txtFfdy.Left = .Left + .CellLeft
            txtFfdy.Top = .Top + .CellTop
            
            cmdKm.Height = txtFfdy.Height
            cmdKm.Left = .Left + .CellLeft + txtFfdy.Width
            cmdKm.Top = txtFfdy.Top
        End With
    End If
End Sub

Private Sub mfgLawless_EnterCell()
    With mfgLawless
        Select Case True
        Case .col = 3
            txtFfdy.Visible = True
            cmdKm.Visible = True
            cmdKm.Height = txtFfdy.Height
            cmdKm.Left = .Left + .CellLeft + txtFfdy.Width
            cmdKm.Top = txtFfdy.Top

            If .cellWidth > cmdKm.Width Then txtFfdy.Width = .cellWidth - cmdKm.Width
            txtFfdy.Height = .cellHeight
            txtFfdy.Left = .Left + .CellLeft
            txtFfdy.Top = .Top + .CellTop
        Case .col = 2
            txtFfdy.Visible = True
            cmdKm.Visible = True
            cmdKm.Height = txtFfdy.Height
            cmdKm.Left = .Left + .CellLeft + txtFfdy.Width
            cmdKm.Top = txtFfdy.Top

            If .cellWidth > cmdKm.Width Then txtFfdy.Width = .cellWidth - cmdKm.Width
            txtFfdy.Height = .cellHeight
            txtFfdy.Left = .Left + .CellLeft
            txtFfdy.Top = .Top + .CellTop
        Case Else
            txtFfdy.Visible = False
            cmdKm.Visible = False
        End Select
    End With
    If Not Loading Then
        If OldRow = 0 Then
            If txtFfdy.Visible Then
                txtFfdy = mfgLawless.TextMatrix(mfgLawless.row, 3)
                txtFfdy.Tag = mfgLawless.TextMatrix(mfgLawless.row, 2)
            End If
        Else
            txtFfdy = oldTxt
            txtFfdy.SelStart = 0
            txtFfdy.SelLength = Len(oldTxt)
            mfgLawless.row = OldRow
            OldRow = 0
            oldTxt = ""
            Valid = False
        End If
        If txtFfdy.Visible Then txtFfdy.SetFocus
    End If
End Sub

Private Sub mfgLawless_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 119 And Shift = 0 Then
    If mfgLawless.COLWIDTH(3) = 0 Then
        mfgLawless.COLWIDTH(3) = 5000
        mfgLawless.COLWIDTH(2) = 0
    Else
        mfgLawless.COLWIDTH(2) = 5000
        mfgLawless.COLWIDTH(3) = 0
    End If
End If
End Sub

Private Sub mfgLawless_LeaveCell()
    Dim strTemp As String
    Dim s As String
    Dim SC As String
    If Not Loading Then
        If Valid Then Exit Sub
        If Not txtFfdy.Visible Or Trim$("" & txtFfdy) = "" Then
            txtFfdy = ""
            oldTxt = ""
            Valid = False
            OldRow = 0
            Exit Sub
        End If
        strTemp = AddDiv(txtFfdy)
        If Not Valid Then
            txtFfdy.Tag = strTemp
            '填充表格
            If txtFfdy.Visible Then
                Dim sTempKm As String
                Dim i As Long
                With mfgLawless
'                    .TextMatrix(.Row, 3) = GetMxKm(txtFfdy, s)
'                     .TextMatrix(.Row, 2) = s
                    .TextMatrix(.row, 2) = txtFfdy.Tag
                    .TextMatrix(.row, 3) = txtFfdy
                    i = .row + 1
                    SC = glo.sSeparateSubject
                    sTempKm = Trim(.TextMatrix(.row, 0))
                    Do While InStr(1, .TextMatrix(i, 0), sTempKm + SC) = 1
                        .TextMatrix(i, 3) = txtFfdy
                        .TextMatrix(i, 2) = txtFfdy.Tag
                        i = i + 1
                    Loop
                    .Refresh
                    End With
            End If
        End If
        txtFfdy.Visible = False
        cmdKm.Visible = False
        txtFfdy = ""
    End If
End Sub

Private Sub mfgLawless_Scroll()
    txtFfdy.Visible = False
    cmdKm.Visible = False
End Sub

Private Sub txtFfdy_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 119 And Shift = 0 Then
    If mfgLawless.COLWIDTH(3) = 0 Then
        mfgLawless.COLWIDTH(3) = 5000
        mfgLawless.COLWIDTH(2) = 0
    Else
        mfgLawless.COLWIDTH(2) = 5000
        mfgLawless.COLWIDTH(3) = 0
    End If
End If
    Select Case KeyCode
        Case vbKeyLeft
            If txtFfdy.SelStart > 1 Then Exit Sub
            If mfgLawless.col = 2 Then mfgLawless.col = mfgLawless.col - 1
        Case vbKeyRight
            If txtFfdy.SelStart < Len(txtFfdy) Then Exit Sub
            If mfgLawless.col = 1 Then mfgLawless.col = mfgLawless.col + 1
        Case vbKeyUp
            If mfgLawless.row > 1 Then mfgLawless.row = mfgLawless.row - 1
        Case vbKeyDown
            If mfgLawless.row < mfgLawless.Rows - 1 Then mfgLawless.row = mfgLawless.row + 1
    End Select
    If KeyCode <> vbKeyDelete And KeyCode <> vbKeyHome And KeyCode <> vbKeyEnd Then KeyCode = 0
    
End Sub

Private Sub txtFfdy_KeyPress(KeyAscii As Integer)
Dim s As String
Dim SC As String
Dim sTemp As String
    If (KeyAscii >= Asc("0") And KeyAscii <= Asc("9")) Or KeyAscii = Asc(",") Or KeyAscii = 13 Or KeyAscii = 8 Or KeyAscii = Asc(glo.sSeparateSubject) Then
        If KeyAscii = 13 Then
            txtFfdy.Visible = False
            cmdKm.Visible = False
        End If
    Else
        KeyAscii = 0
    End If
    If KeyAscii = 13 Then
        Dim sTempKm As String
        Dim i As Integer
        With mfgLawless
            sTemp = AddDiv(txtFfdy)
            If Valid = False Then
                .TextMatrix(.row, 3) = txtFfdy
                .TextMatrix(.row, 2) = sTemp
            End If
            i = 1
            SC = glo.sSeparateSubject
            sTempKm = Trim(.TextMatrix(.row, 0))
            Do While (.row + i < .Rows)
                If InStr(1, .TextMatrix(.row + i, 0), sTempKm + SC) = 1 Then
                     sTemp = AddDiv(txtFfdy)
                    If Valid = False Then
                        .TextMatrix(.row, 3) = txtFfdy
                        .TextMatrix(.row, 2) = sTemp
                    End If
                Else
                     Exit Do
                End If
                i = i + 1
            Loop
            .Refresh
        End With
        mfgLawless.SetFocus
    End If
End Sub
'用"'"号分隔科目代码并检查此科目是否存在
'曹
Private Function AddDiv(strSource As String) As String
    Dim strKmlist As String
    Dim i As Integer, j As Integer
    Dim rstTemp As ADODB.Recordset

    strKmlist = "'"
    Set rstTemp = New ADODB.Recordset
    j = 1
    For i = 1 To Len(strSource)
        If Mid(strSource, i, 1) = "," Then
            If rstTemp.State = adStateOpen Then rstTemp.Close
            rstTemp.Open "select kmdm from tZW_Km" & glo.sOperateYear & " where kmdm='" & Mid(strSource, j, i - j) & "'", glo.cnnMain, adOpenStatic, adLockOptimistic
            If rstTemp.BOF And rstTemp.EOF And Not Loading Then
                MsgBox "含有非法科目，或科目不存在！", vbInformation
                OldRow = mfgLawless.row
                oldTxt = mfgLawless.TextMatrix(mfgLawless.row, 3)
                AddDiv = ""
                Valid = True
                Exit Function
            End If
            j = i + 1
            strKmlist = strKmlist & "'" & "," & "'"
        Else
            strKmlist = strKmlist & Mid(strSource, i, 1)
        End If
    Next i
        '只有一个科目或最后一个科目检查
    If Not Loading Then
       If Mid(txtFfdy, j, i - j) <> "" Then
            If rstTemp.State = adStateOpen Then rstTemp.Close
            rstTemp.Open "select kmdm from tZW_Km" & glo.sOperateYear & " where kmdm='" & Mid(txtFfdy, j, i - j) & "'", glo.cnnMain, adOpenStatic, adLockOptimistic
            If rstTemp.BOF And rstTemp.EOF Then
                MsgBox "最后一项科目不存在！", vbInformation
                oldTxt = mfgLawless.TextMatrix(mfgLawless.row, 3)
                OldRow = mfgLawless.row
                AddDiv = ""
                Valid = True
                Exit Function
            End If
       Else
          AddDiv = ""
          Exit Function
       End If
    End If
    '合法性检查完毕，已经合法
    OldRow = 0
    Valid = False
    '获取科目名称列表
    If rstTemp.State = adStateOpen Then rstTemp.Close
    rstTemp.Open "select Kmmc from tZW_Km" & glo.sOperateYear & " where kmdm in (" & strKmlist & "')", glo.cnnMain, adOpenStatic, adLockOptimistic
    With rstTemp
        strKmlist = ""
        If .RecordCount <> 0 Then
            If Not .BOF Then .MoveFirst
            While Not .EOF
                strKmlist = strKmlist & "," & Trim$(.Fields(0))
                .MoveNext
            Wend
        Else
            AddDiv = ""
            Exit Function
        End If
    End With
    rstTemp.Close
    Set rstTemp = Nothing
    
    AddDiv = Right(strKmlist, Len(strKmlist) - 1)
End Function

Public Function GetMxKm(ByVal s As String, ByRef Kmmc As String) As String
Dim rSt As New Recordset
Dim sKmdm() As String
Dim sSQL As String
Dim i As Integer
If Trim(s) = "" Then Exit Function
sKmdm() = Split(s, ",")
sSQL = ""
For i = LBound(sKmdm) To UBound(sKmdm)
    sSQL = sSQL + " or  kmdm like '" + sKmdm(i) + "%'"
Next i
sSQL = "select distinct(kmdm), kmmc from tZw_km" + glo.sOperateYear + " where (" + Mid(sSQL, 5) + ") and isendkm=-1 order by kmdm"
rSt.Open sSQL, glo.cnnMain, adOpenKeyset, adLockPessimistic
GetMxKm = ""
Kmmc = ""
While Not rSt.EOF
    GetMxKm = GetMxKm + "," + rSt.Fields(0).Value
    Kmmc = Kmmc + "," + rSt.Fields(1).Value
    rSt.MoveNext
Wend
GetMxKm = Mid(GetMxKm, 2)
Kmmc = Mid(Kmmc, 2)
End Function