frmin_summary.frm

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

    Cllr.WorkbookReadonly = False
    txtCode.Enabled = True
    txtName.Enabled = True
    txtKmdm.Enabled = True
    cmdKMHelp.Enabled = True
Case "Edit"
    m_sStatus = "修改"
    tbr.Buttons("Append").Enabled = False
    tbr.Buttons("Modify").Enabled = False
    tbr.Buttons("Delete").Enabled = False
    tbr.Buttons("Save").Enabled = True
    tbr.Buttons("Cancel").Enabled = True
    mnuEditAppend.Enabled = False
    mnuEditModify.Enabled = False
    mnuEditDelete.Enabled = False
    mnuEditSave.Enabled = True
    mnuEditCancel.Enabled = True
    tbr.Buttons("Selected").Enabled = False
    mnuEditSelected.Enabled = False
    Cllr.WorkbookReadonly = False
    txtCode.Enabled = True
    txtName.Enabled = True
    txtKmdm.Enabled = True
    cmdKMHelp.Enabled = True
Case "Delete"
    m_sStatus = ""
Case "Save"
    m_sStatus = ""
    tbr.Buttons("Append").Enabled = True
    tbr.Buttons("Modify").Enabled = True
    tbr.Buttons("Delete").Enabled = True
    tbr.Buttons("Save").Enabled = False
    tbr.Buttons("Cancel").Enabled = False
    mnuEditAppend.Enabled = True
    mnuEditModify.Enabled = True
    mnuEditDelete.Enabled = True
    mnuEditSave.Enabled = False
    mnuEditCancel.Enabled = False
    tbr.Buttons("Selected").Enabled = ubSelectStatus
    mnuEditSelected.Enabled = ubSelectStatus
    Cllr.WorkbookReadonly = True
    txtCode.Enabled = False
    txtName.Enabled = False
    txtKmdm.Enabled = False
    cmdKMHelp.Enabled = False
Case "Cancel"
    m_sStatus = ""
    tbr.Buttons("Append").Enabled = True
    tbr.Buttons("Modify").Enabled = True
    tbr.Buttons("Delete").Enabled = True
    tbr.Buttons("Save").Enabled = False
    tbr.Buttons("Cancel").Enabled = False
    mnuEditAppend.Enabled = True
    mnuEditModify.Enabled = True
    mnuEditDelete.Enabled = True
    mnuEditSave.Enabled = False
    mnuEditCancel.Enabled = False
    tbr.Buttons("Selected").Enabled = ubSelectStatus
    mnuEditSelected.Enabled = ubSelectStatus
    Cllr.WorkbookReadonly = True
    txtCode.Enabled = False
    txtName.Enabled = False
    
    txtKmdm.Enabled = False
    cmdKMHelp.Enabled = False
Case Else
    m_sStatus = ""
    tbr.Buttons("Append").Enabled = True
    tbr.Buttons("Modify").Enabled = False
    tbr.Buttons("Delete").Enabled = False
    tbr.Buttons("Save").Enabled = False
    tbr.Buttons("Cancel").Enabled = False
    mnuEditAppend.Enabled = True
    mnuEditModify.Enabled = False
    mnuEditDelete.Enabled = False
    mnuEditSave.Enabled = False
    mnuEditCancel.Enabled = False
    tbr.Buttons("Selected").Enabled = False
    mnuEditSelected.Enabled = False
    Cllr.WorkbookReadonly = True
    txtCode.Enabled = False
    txtName.Enabled = False
End Select
End Sub

Private Sub mnuEditAppend_Click()
    
    txtCode.text = ""
    txtCode.Tag = ""
    txtName.text = ""
    txtKmdm.text = ""
    ControlMenu "New"
    txtCode.SetFocus
End Sub

Private Sub mnuEditCancel_Click()
    ControlMenu "Cancel"
    txtCode.text = txtCode.Tag
    txtName.text = txtName.Tag
End Sub

Private Sub mnuEditDelete_Click()
    Dim adoCmd As ADODB.Command
    
    If MsgBox(e_MSG_ASK_DELETE, vbQuestion + vbYesNo) = vbYes Then
        Set adoCmd = New ADODB.Command
        With adoCmd
            .ActiveConnection = glo.cnnMain
            .CommandType = adCmdText
            .CommandText = "DELETE FROM " & sTable & " WHERE " & _
                sFIELD_CODE & "='" & txtCode.Tag & "'"
            .Execute
        End With
        txtName.text = ""
        txtKmdm.text = ""
        Dim L As Long
        With Cllr
            L = .GetRows(0)
            While L > 2
                If .GetCellString(1, L, 0) = txtCode.text Then
                    .DeleteRow L, 1, 0
                    CllR_SelChanged 1, L, 1, L
                    L = 2
                End If
                L = L - 1
            Wend
        End With

        ControlMenu "Delete"
        
    End If
    
End Sub

Private Sub mnuEditModify_Click()
    ControlMenu "Edit"
    txtCode.Tag = txtCode.text
    txtName.Tag = txtName.text
End Sub

Private Sub mnuEditSave_Click()
    Dim rSt As ADODB.Recordset
    Dim adoCmd As ADODB.Command
    Dim rstKm As New Recordset
    If Trim$(txtKmdm.text) <> "" Then
        rstKm.Open "Select * from tZW_Km" + glo.sOperateYear + _
            " where Kmdm='" + txtKmdm.text + "'", glo.cnnMain, adOpenDynamic, adLockOptimistic
        If rstKm.EOF Then
            MsgBox "非法科目"
            txtKmdm.text = ""
        Else
            txtKmdm.Tag = txtKmdm.text
            txtKmdm.text = rstKm.Fields("kmdm").value
        End If
        rstKm.Close
    End If
    
    If txtCode.text = "" Then
        MsgBox "请输入代码！", vbInformation
        txtCode.SetFocus
        Exit Sub
    ElseIf SqlStringValid(txtCode) = False Then
        MsgBox "科目代码不能含有非法的字符！", vbInformation, "提示"
        Exit Sub
    Else
        If m_sStatus = "修改" And txtCode.Tag = "" Then
            MsgBox "必须选中已有的记录！", vbInformation
            Exit Sub
        End If
        Set rSt = New ADODB.Recordset
        rSt.Open "SELECT COUNT(*) FROM " & sTable & " WHERE " & _
                sFIELD_CODE & "='" & Trim$(txtCode.text) & "'", _
                glo.cnnMain, adOpenStatic, adLockReadOnly
        If Not (IsNull(rSt.Fields(0).value)) Then
            If rSt.Fields(0).value > 0 Then
                If (m_sStatus = "修改" And txtCode.text <> txtCode.Tag) Or m_sStatus = "新增" Then
                    MsgBox "代码已存在，请更换！", vbInformation
                    Call FullSelTextbox(txtCode)
                    rSt.Close
                    Exit Sub
                End If
            Else
                If rSt.Fields(0).value = 0 And m_sStatus = "修改" And txtCode.text = txtCode.Tag Then
                    MsgBox "未发现要修改的记录！", vbInformation
                    Call FullSelTextbox(txtCode)
                    rSt.Close
                    Exit Sub
                End If
            End If
        Else
            If m_sStatus = "修改" And txtCode.text = txtCode.Tag Then
                MsgBox "未发现要修改的记录！", vbInformation
                Call FullSelTextbox(txtCode)
                rSt.Close
                Exit Sub
            End If
        End If
        rSt.Close
     
    End If
  
    
    If Trim$(txtName.text) = "" Then
        MsgBox "请输入内容！", vbInformation
        txtName.SetFocus
        Exit Sub
    ElseIf Not SqlStringValid(txtName.text) Then
        MsgBox e_MSG_SQLVALID, vbInformation
        Call FullSelTextbox(txtName)
        Exit Sub
    ElseIf LenB(StrConv(txtName.text, vbFromUnicode)) > txtName.MaxLength Then
        MsgBox "输入超长！最长为40个字符(即20个汉字)。", vbInformation
        Call FullSelTextbox(txtName)
        Exit Sub
    End If
    
    MousePointer = vbHourglass
    Set adoCmd = New ADODB.Command
    With adoCmd
        .ActiveConnection = glo.cnnMain
        .CommandType = adCmdText
        If m_sStatus = "新增" Then
            If txtKmdm.text = "" Then
                .CommandText = "INSERT INTO " & sTable & "(" & sFIELD_CODE & _
                    "," & sFIELD_NAME & ") VALUES('" & Trim(txtCode.text) & _
                    "','" & Trim(txtName.text) & "')"
            Else
                .CommandText = "INSERT INTO " & sTable & "(" & sFIELD_CODE & _
                    "," & sFIELD_NAME & ",kmdm) VALUES('" & Trim(txtCode.text) & _
                    "','" & Trim(txtName.text) & "','" + txtKmdm.text + "')"
            End If
        Else
            If txtKmdm.text = "" Then
                .CommandText = "UPDATE " & sTable & " SET " & sFIELD_NAME & _
                    "='" & Trim(txtName.text) & "', " + sFIELD_CODE + "='" + Trim(txtCode.text) + "',kmdm=NULL WHERE " & sFIELD_CODE & _
                    "='" & Trim(txtCode.Tag) & "'"
            Else
                .CommandText = "UPDATE " & sTable & " SET " & sFIELD_NAME & _
                "='" & Trim(txtName.text) & "', " + sFIELD_CODE + "='" + Trim(txtCode.text) + "',kmdm='" + txtKmdm.text + "' WHERE " & sFIELD_CODE & _
                "='" & Trim(txtCode.Tag) & "'"
            End If
        End If
        .Execute
    End With
    
'    With CllR
'        If m_sStatus = "新增" Then
'            .InsertRow .GetRows(0), 1, 0
'            .SetCellString 1, .GetRows(0) - 1, 0, txtCode.text
'            .SetCellString 2, .GetRows(0) - 1, 0, txtKmdm.text
'            .SetCellString 3, .GetRows(0) - 1, 0, txtName.text
'        Else
'            .SetCellString 3, .GetCurrentRow, 0, txtName.text
'            .SetCellString 2, .GetCurrentRow, 0, txtKmdm.text
'            .SetCellString 1, .GetCurrentRow, 0, txtCode.text
'        End If
'    End With
'    CllR.DrawGridLine 1, 2, 2, CllR.GetRows(0) - 1, 0, 2, vbBlack
    FillGrid
    Me.MousePointer = vbNormal
    ControlMenu "Save"
End Sub

Private Sub mnuEditSelected_Click()
    m_sName = txtName.text
    Ok = True
    Me.Hide
End Sub

Private Sub mnuFileExit_Click()
    Unload Me
End Sub

Private Sub mnuFilePreview_Click()
Cllr.SetRowUnhidden 1, 1
Cllr.PrintPreview 1, 0
Cllr.SetRowHidden 1, 1
Cllr.ShowSheetLabel 0, 0
Cllr.ShowSideLabel 0, 0
Cllr.ShowTopLabel 0, 0
End Sub

Private Sub mnuFilePrint_Click()
Cllr.SetRowUnhidden 1, 1
Cllr.PrintSheet 1, 0
Cllr.SetRowHidden 1, 1
Cllr.ShowSheetLabel 0, 0
Cllr.ShowSideLabel 0, 0
Cllr.ShowTopLabel 0, 0
End Sub

Private Sub mnuHelpTheme_Click()
 Dim nRet As Integer
    If Len(App.HelpFile) = 0 Then
        MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation
    Else
        On Error Resume Next
        nRet = HtmlHelp(Me.hwnd, App.Path & "\Help Files\" & App.ProductName & ".chm", _
        HH_HELP_CONTEXT, CLng(Me.HelpContextID))
        If Err Then
            MsgBox Err.Dscription
        End If
    End If
End Sub

Private Sub tbr_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Key
        Case "Preview"
            Call mnuFilePreview_Click
        Case "Print"
            Call mnuFilePrint_Click
        Case "Append"
            Call mnuEditAppend_Click
        Case "Modify"
            Call mnuEditModify_Click
        Case "Delete"
            Call mnuEditDelete_Click
        Case "Save"
            Call mnuEditSave_Click
        Case "Cancel"
            Call mnuEditCancel_Click
        Case "Selected"
            Call mnuEditSelected_Click
        Case "Quit"
            Call mnuFileExit_Click
        Case "Help"
            Call mnuHelpTheme_Click
    End Select
End Sub

Private Sub SetGrid()


Cllr.SetCols 4, 0
Cllr.SetRows 3, 0

Cllr.SetRowHeight 1, 34, 1, 0

Cllr.SetColWidth 1, 50, 1, 0
Cllr.SetColWidth 1, 100, 2, 0
Cllr.SetColWidth 1, 300, 3, 0

Cllr.MergeCells 1, 1, 2, 1
Cllr.SetCellFont 1, 1, 0, Cllr.FindFontIndex("宋体", 1)
Cllr.SetCellFontSize 1, 1, 0, 18
Cllr.SetCellFontStyle 1, 1, 0, 2
Cllr.SetCellString 1, 1, 0, "凭证摘要"
Cllr.SetCellAlign 1, 1, 0, 36

Cllr.SetCellFont 1, 2, 0, Cllr.FindFontIndex("宋体", 1)
Cllr.SetCellFontSize 1, 2, 0, 10
Cllr.SetCellFontStyle 1, 2, 0, 2
Cllr.SetCellString 1, 2, 0, "代码"
Cllr.SetCellAlign 1, 2, 0, 36

Cllr.SetCellFont 2, 2, 0, Cllr.FindFontIndex("宋体", 1)
Cllr.SetCellFontSize 2, 2, 0, 10
Cllr.SetCellFontStyle 2, 2, 0, 2
Cllr.SetCellString 2, 2, 0, "科目"
Cllr.SetCellAlign 2, 2, 0, 36

Cllr.SetCellFont 3, 2, 0, Cllr.FindFontIndex("宋体", 1)
Cllr.SetCellFontSize 3, 2, 0, 10
Cllr.SetCellFontStyle 3, 2, 0, 2
Cllr.SetCellString 3, 2, 0, "摘要"
Cllr.SetCellAlign 3, 2, 0, 36

Cllr.SetRowHidden 1, 1
Cllr.PrintSetTopTitle 1, 2
Cllr.PrintSetHead "", "", "第&P页"
Cllr.WorkbookReadonly = True
Cllr.AllowDragdrop = False
Cllr.ShowSheetLabel 0, 0
Cllr.ShowSideLabel 0, 0
Cllr.ShowTopLabel 0, 0
Cllr.SetSelectMode 0, 2
Cllr.ShowPageBreak False

Cllr.Login "南京伊康计算机工程公司", "11010504", "0060-1733-7722-3004"
End Sub

Private Sub FillGrid()
Dim rSt As New Recordset
Dim lRow As Long
Dim sKmdm As String
Dim sKmdmStr As String
rSt.CursorLocation = adUseClient
If Trim$(m_sKmdm) <> "" Then
    sKmdm = m_sKmdm
    sKmdmStr = sKmdm
    While sKmdmStr <> ""
        sKmdmStr = GetParentKmdm(sKmdmStr)
        sKmdm = sKmdm + "','" + sKmdmStr
    Wend
    rSt.Open "Select * from tZw_Zywh  where kmdm in ('" + sKmdm + "') or kmdm is null or rtrim(kmdm)='' order by DmID", glo.cnnMain, adOpenKeyset, adLockPessimistic
Else
    rSt.Open "Select * from tZw_Zywh order by DmID ", glo.cnnMain, adOpenKeyset, adLockPessimistic
End If
Cllr.SetRows rSt.RecordCount + 3, 0
lRow = 3
While Not rSt.EOF
    Cllr.SetCellString 1, lRow, 0, Trim("" + rSt.Fields("DmID").value)
    If Not IsNull(rSt.Fields("kmdm").value) Then
        Cllr.SetCellString 2, lRow, 0, Trim$(rSt.Fields("Kmdm").value)
    Else
        Cllr.SetCellString 2, lRow, 0, ""
    End If
    Cllr.SetCellString 3, lRow, 0, Trim("" + rSt.Fields("Name").value)
    lRow = lRow + 1
    rSt.MoveNext
Wend
Cllr.DrawGridLine 1, 2, 3, lRow - 1, 0, 2, vbBlack
Cllr.SetCellString 1, lRow, 0, "制表单位:" + glo.sAccountName
Cllr.SetCellAlign 1, lRow, 0, 33
Cllr.SetCellString 2, lRow, 0, "（打印时间：" + Date$ + "）"
Cllr.SetCellAlign 2, lRow, 0, 34
End Sub

Private Sub txtCode_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then SendKeys "{TAB}"
KeyAscii = IntegerEnabled(KeyAscii)
End Sub

Private Sub txtKmdm_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    Dim rstKm As New Recordset
    If Trim$(txtKmdm) <> "" Then
        rstKm.Open "Select IsEndKm,Kmdm from tZW_Km" + glo.sOperateYear + _
            " where Kmdm='" + Trim$(txtKmdm.text) + "'", glo.cnnMain, adOpenDynamic, adLockOptimistic
        If rstKm.EOF Then
            MsgBox "非法科目"
            txtKmdm.text = ""
            txtKmdm.Tag = ""
        Else
            txtKmdm.Tag = Trim$(txtKmdm.text)
            txtKmdm.text = rstKm.Fields("kmdm").value
        End If
        rstKm.Close
    End If
    SendKeys "{TAB}"
End If
End Sub

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

Public Property Get usKmdm() As String
usKmdm = m_sKmdm
End Property

Public Property Let usKmdm(ByVal vNewValue As String)
m_sKmdm = vNewValue
End Property