frmyh_yhdzdlr.frm

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

Private Sub mnuPrint_Click()
    Call Operate("PRINT")
End Sub

Private Sub mnuSave_Click()
    Call Operate("SAVE")
End Sub

'工具条
Private Sub tbr_ButtonClick(ByVal Button As MSComctlLib.Button)
    Call Operate(UCase(Button.Key))
End Sub

Private Sub Operate(strKey As String)
    Dim CurrentColNum As Integer
    Dim IsAddRow As Boolean          '判断当前单元行是否是新增行中的某一行
    On Error Resume Next
    Select Case strKey
        Case "PRINT"
         If Printers.Count = 0 Then
            MsgBox "请安置打印机！", vbInformation
            Exit Sub
         End If
            With mfgYhdzdlr
                If .row > 0 Then
                    Call mfgYhdzdlr_LeaveCell
                    If IsValidate Then
                        Call ShowPrintResult("PRINT")
                    Else
                        .col = ErrorCol
                        Call mfgYhdzdlr_GotFocus1
                        Exit Sub
                    End If
                Else
                    Call ShowPrintResult("PRINT")
                End If
                
            End With
        Case "PREVIEW"
            If Printers.Count = 0 Then
               MsgBox "请安置打印机！", vbInformation
               Exit Sub
            End If
            With mfgYhdzdlr
                If .row > 0 Then
                    Call mfgYhdzdlr_LeaveCell
                    If IsValidate Then
                        Call ShowPrintResult("PREVIEW")
                    Else
                        .col = ErrorCol
                        Call mfgYhdzdlr_GotFocus1
                        Exit Sub
                    End If
                Else
                    Call ShowPrintResult("PREVIEW")
                End If
                
            End With
           
        Case "NEW"
            With mfgYhdzdlr
                If .row > 0 And .CellBackColor <> &HFFFFC0 Then
                    Call mfgYhdzdlr_LeaveCell
                    If IsValidate Then
                        If IsModify Then
                            Call UpdateCurrentRow
                        End If
                        IsRefresh = True
                        Call AddNewRow
                        IsRefresh = False
                        Call mfgYhdzdlr_GotFocus1
                    Else
                        .col = ErrorCol
                        Call mfgYhdzdlr_GotFocus1
                    End If
                Else
                    Call AddNewRow
                End If
            End With
        
        Case "SAVE"
         On Error GoTo errhandle
            Call mfgYhdzdlr_LeaveCell
            NewRow = mfgYhdzdlr.row
            NewCol = mfgYhdzdlr.col
            If IsValidate Then
                Call InsertCurrentRow
                With tBr
                    .Buttons("print").Enabled = True
                    .Buttons("preview").Enabled = True
                    .Buttons("new").Enabled = True
                    .Buttons("save").Enabled = False
                    .Buttons("cancel").Enabled = False
                    .Buttons("delete").Enabled = True
                    .Buttons("filter").Enabled = True
                    .Buttons("exit").Enabled = True
                    mnuPrint.Enabled = True
                    mnuPreview.Enabled = True
                    mnuNew.Enabled = True
                    mnuSave.Enabled = False
                    mnuCancel.Enabled = False
                    mnuDelete.Enabled = True
                    mnuFilter.Enabled = True
                    mnuExit.Enabled = True
                End With
                Call AutoDateSort
                Call RefreshYe
                IsModify = False
                IsDateModify = False
            Else
                mfgYhdzdlr.col = ErrorCol
                Call mfgYhdzdlr_GotFocus1
            End If
            Exit Sub
errhandle:
            MsgBox "参数不完整或有误,请检查!", vbInformation
            Exit Sub
        Case "CANCEL"
            With tBr
                .Buttons("print").Enabled = True
                .Buttons("preview").Enabled = True
                .Buttons("new").Enabled = True
                .Buttons("save").Enabled = False
                .Buttons("cancel").Enabled = False
                .Buttons("delete").Enabled = True
                .Buttons("filter").Enabled = True
                .Buttons("exit").Enabled = True
                mnuPrint.Enabled = True
                mnuPreview.Enabled = True
                mnuNew.Enabled = True
                mnuSave.Enabled = False
                mnuCancel.Enabled = False
                mnuDelete.Enabled = True
                mnuFilter.Enabled = True
                mnuExit.Enabled = True
            End With
            Call mfgYhdzdlr_LeaveCell
            With mfgYhdzdlr
                CurrentColNum = .col
                If .Rows = 2 Then
                    .Rows = 1
                    tBr.Buttons("delete").Enabled = False
                    mnuDelete.Enabled = False
                Else
                    .RemoveItem (.row)
                End If
                If .row = 0 Then
                    .col = 0
                Else
                    .col = CurrentColNum
                End If
            End With
        Case "DELETE"
            With mfgYhdzdlr
                If .row > 0 And .CellBackColor <> &HFFFFC0 Then
                    Call mfgYhdzdlr_LeaveCell
                    IsDelete = True
'                    If IsValidate Then
'                        If IsModify Then
'                            Call UpdateCurrentRow
'                        End If
                        
                        CurrentColNum = .col
                        .ScrollBars = flexScrollBarNone
                        For j = .Cols - 1 To 0 Step -1
                            .col = j
                            .CellBackColor = vbMagenta
                        Next j
                        If MsgBox("确认删除当前行?", vbYesNo + vbQuestion + vbDefaultButton2) = vbYes Then
                        
                            IsChangeCurrentTable = True
                            adoCmd.CommandText = "DELETE FROM tZW_yhdzd" & glo.sOperateYear & _
                                                    " WHERE id = " & .TextMatrix(.row, 0)
                            adoCmd.Execute
                            '当总行数为2时, 不能用'removeitem" 方法, 只能设置总行数为1
                            If .Rows = 2 Then
                                .Rows = 1
                                tBr.Buttons("delete").Enabled = False
                                mnuDelete.Enabled = False
                            Else
                                .RemoveItem (.row)
                            End If
                            .ScrollBars = flexScrollBarBoth
                        Else
                            For j = .Cols - 1 To 0 Step -1
                            .col = j
                            .CellBackColor = vbWhite
                            Next j
                            .ScrollBars = flexScrollBarBoth
                        End If
                        IsDelete = False
                        If .row = 0 Then
                            .col = 0
                        Else
                            .col = CurrentColNum
                        End If
'                    Else
'                        IsDelete = False
'                        .Col = ErrorCol
'                        Call mfgYhdzdlr_GotFocus1
'                    End If
                End If
            End With
        Case "FILTER"
            IsChangeCurrentTable = True
            With mfgYhdzdlr
                If .row <> 0 And .CellBackColor <> &HFFFFC0 Then
                    .col = 0
                    If IsValidate Then
                        If IsModify Or IsDateModify Then
                            Call UpdateCurrentRow
                        End If
                        Call QueryConditionInput
                    Else
                        .col = ErrorCol
                    End If
                Else
                    Call QueryConditionInput
                End If
                '为了筛选后不要调用isvalidate程序,将oldrow设置为零
                OldRow = 0
            End With
        Case "HELP"
            Call ShowHelp
        Case "EXIT"
            Unload Me
    End Select
End Sub

'新增加一行
Private Sub AddNewRow()
    With tBr
        .Buttons("print").Enabled = False
        .Buttons("preview").Enabled = False
        .Buttons("new").Enabled = False
        .Buttons("save").Enabled = True
        .Buttons("cancel").Enabled = True
        .Buttons("delete").Enabled = False
        .Buttons("filter").Enabled = False
        .Buttons("exit").Enabled = False
        mnuPrint.Enabled = False
        mnuPreview.Enabled = False
        mnuNew.Enabled = False
        mnuSave.Enabled = True
        mnuCancel.Enabled = True
        mnuDelete.Enabled = False
        mnuFilter.Enabled = False
        mnuExit.Enabled = False
    End With

    With mfgYhdzdlr
        CurrentRowNum = .Rows
        .AddItem "" & vbTab & "" & vbTab & "" & vbTab & "" & vbTab & "" & vbTab & _
                "" & vbTab & "" & vbTab & "" & vbTab & "" & vbTab & CurrentRowNum
        .RowHeight(CurrentRowNum) = cboEdit.Height
        .row = CurrentRowNum
        .col = 2
    End With
End Sub


'调用查询条件输入窗体
Private Sub QueryConditionInput()
    Myfrmcx.Show 1
    With Myfrmcx
        If .IsOk Then
            If .chkNoFilter = 1 Then
                Call FillGrid(sSQL)
                .chkNoFilter = 0
            Else
                Call FillGrid(GetQueryStr)
            End If
        Else
            If .chkNoFilter = 1 Then
                .chkNoFilter = 0
            End If
        End If
    End With
End Sub

'从"frmYH_yhcxtj"查询条件窗体中得到查询字符串
Private Function GetQueryStr() As String
    With Myfrmcx
        If .chkNoFilter.value = 0 Then
            GetQueryStr = "SELECT * FROM tZW_yhdzd" & glo.sOperateYear & " WHERE "
            If .txtQsrq.text <> "____-__-__" Then
                Select Case g_FLAT
                    Case "SQL"
                        GetQueryStr = GetQueryStr & "rq >= '" & .txtQsrq.text & "' AND "
                    Case "ORACLE"
                        GetQueryStr = GetQueryStr & "TO_CHAR(rq,'yyyy-mm-dd') >= '" & .txtQsrq.text & "' AND "
                End Select
            End If
            If .txtJsrq.text <> "____-__-__" Then
                Select Case g_FLAT
                    Case "SQL"
                        GetQueryStr = GetQueryStr & "rq <= '" & .txtJsrq.text & "' AND "
                    Case "ORACLE"
                        GetQueryStr = GetQueryStr & "TO_CHAR(rq,'yyyy-mm-dd') <= '" & .txtJsrq.text & "' AND "
                End Select
            End If
            If .cboJsfs.text <> "" Then
                GetQueryStr = GetQueryStr & "jsfsCode = '" & Left(.cboJsfs.text, InStr(.cboJsfs.text, " ") - 1) & "' AND "
            End If
            If .txtBill.text <> "" Then
                GetQueryStr = GetQueryStr & "bill = '" & .txtBill.text & "' AND "
            End If
            If .optJf.value Then
                GetQueryStr = GetQueryStr & "fx = '借' AND "
            ElseIf .optDf.value Then
                GetQueryStr = GetQueryStr & "fx = '贷' AND "
            End If
            If .txtQsje.text <> "" Then
                GetQueryStr = GetQueryStr & "je >= " & Val(Format(.txtQsje.text, "###0.00")) & " AND "
            End If
            If .txtJsje.text <> "" Then
                GetQueryStr = GetQueryStr & "je <= " & Val(Format(.txtJsje.text, "###0.00")) & " AND "
            End If
            GetQueryStr = GetQueryStr & "kmdm = '" & frmYH_Yhkmxz.kmdm & "' AND qcbz <> 0  AND hxbz = 0 ORDER BY rq,jsfsCode,Bill"
        End If
    End With
End Function

'从"frmYH_yhcxtj"查询条件窗体中得到期初
Private Function GetQc(ByVal Id As String, ByVal rq As Date) As Double
    Debug.Print Id
    Dim rSt As New Recordset
    rSt.Open "Select Sum(je) as je,fx from tZW_Yhdzd" + glo.sOperateYear + " where kmdm='" + frmYH_Yhkmxz.kmdm + "' " + _
        " and (rq<" + GetDateString(g_FLAT, rq) + " or (rq=" + GetDateString(g_FLAT, rq) + " and id<" + Id + ")) and hxbz = 0 group by fx", glo.cnnMain, adOpenDynamic, adLockOptimistic
    GetQc = 0
    While Not rSt.EOF
        If Left(rSt.Fields("fx").value, 1) = "借" Then