frmyh_yhdz.frm

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

                        IsSelect = False
                    Else
                        If DWFocus Then
                            Call QueryDwrjz
                        Else
                            Call QueryYhdzd
                        End If
                        IsSelect = True
                    End If
                    Me.MousePointer = vbDefault
                Else
                    If frmYH_Yhcxtj.chkNoFilter = 1 Then
                        frmYH_Yhcxtj.chkNoFilter = 0
                    End If
                End If
                If Not IsPress Then
                    .Buttons("match").value = tbrPressed
                End If
            Case "MATCH"
                If IsPress Then
                    IsPress = False
                    .Buttons("match").value = tbrPressed
                    Call YhdzMatch
                Else
                    IsPress = True
                    .Buttons("match").value = tbrUnpressed
                    If IsSelect Then
                        Call QueryYhdzd
                    Else
                        '如果不显示已达账
                        If chkYdz.value = 0 Then
                            With mfgYhdzd
                                For i = 1 To .Rows - 1
                                    If .TextMatrix(i, 6) <> "" Then
                                        .RowHeight(i) = 0
                                    Else
                                        .RowHeight(i) = 225
                                    End If
                                Next i
                            End With
                        '否则显示已达账
                        Else
                            With mfgYhdzd
                                For i = 1 To .Rows - 1
                                    .RowHeight(i) = 225
                                Next i
                            End With
                        End If
                    End If
                End If
            Case "CHECK"
                Me.Refresh
                If Not IsPress Or IsSelect Then
                    .Buttons("match").value = tbrUnpressed
                    .Refresh
                    IsPress = True
                    IsSelect = False
                End If
                frmYH_YhdzPhCheck.Show 1
            Case "HELP"
                Call ShowHelp
                If Not IsPress Then
                    .Buttons("match").value = tbrPressed
                End If
            Case "EXIT"
                Unload Me
        End Select
    End With
End Sub

Public Function IsExitCollection(ByVal Key As String, ByRef coll As Collection) As Boolean
Dim n As Object
On Error GoTo Err
    Call coll.Item(Key)
    IsExitCollection = True
Exit Function
Err:
    IsExitCollection = False
End Function

Private Sub dz()
'    Debug.Print Now
    Dim coll As New VBA.Collection
    Dim Je As Double
    Dim YhCurRow As Integer
    Dim DwCurRow As Integer
    Dim oValue As String
    For YhCurRow = 1 To mfgYhdzd.Rows - 1
        If mfgYhdzd.TextMatrix(YhCurRow, 6) = "" And mfgYhdzd.TextMatrix(YhCurRow, 1) <= _
            Format(frmYH_Yhdztj.dtpJzrq.value, "yyyy-mm-dd") Then
            YhdzdRq = Format(mfgYhdzd.TextMatrix(YhCurRow, 1), "yyyy-mm-dd")
            YhdzdJsfsCode = mfgYhdzd.TextMatrix(YhCurRow, 2)
            YhdzdBill = mfgYhdzd.TextMatrix(YhCurRow, 3)
            YhdzdFx = mfgYhdzd.TextMatrix(YhCurRow, 4)
            YhdzdJe = mfgYhdzd.TextMatrix(YhCurRow, 5)
'            If Left(YhdzdFx, 1) = "借" Then
'                je = YhdzdJe
'            Else
'                je = -1 * YhdzdJe
'            End If
            Je = Abs(YhdzdJe)
            If IsExitCollection("k" + CStr(Je), coll) Then
                oValue = coll.Item("k" + CStr(Je)) + ",Y" + CStr(YhCurRow)
                Call coll.Remove("k" + CStr(Je))
                Call coll.Add(oValue, "k" + CStr(Je))
            Else
                Call coll.Add("Y" + CStr(YhCurRow), "k" + CStr(Je))
            End If
        End If
    Next
    Dim sRowID As String
    For DwCurRow = 1 To mfgDwrjz.Rows - 1
        If mfgDwrjz.TextMatrix(DwCurRow, 9) = "" And _
            mfgDwrjz.TextMatrix(DwCurRow, 3) <= _
            Format(frmYH_Yhdztj.dtpJzrq.value, "yyyy-mm-dd") Then
            DwrjzPzrq = mfgDwrjz.TextMatrix(DwCurRow, 3)
            DwrjzJsfsCode = mfgDwrjz.TextMatrix(DwCurRow, 5)
            DwrjzBill = mfgDwrjz.TextMatrix(DwCurRow, 6)
            DwrjzFx = mfgDwrjz.TextMatrix(DwCurRow, 7)
            DwrjzJe = mfgDwrjz.TextMatrix(DwCurRow, 8)
'            If Left(YhdzdFx, 1) <> "借" Then
'                je = DwrjzJe
'            Else
'                je = -1 * DwrjzJe
'            End If
            Je = Abs(DwrjzJe)
            If IsExitCollection("k" + CStr(Je), coll) Then
                oValue = coll.Item("k" + CStr(Je)) + ",D" + CStr(DwCurRow)
                Call coll.Remove("k" + CStr(Je))
                Call coll.Add(oValue, "k" + CStr(Je))
            Else
                Call coll.Add("D" + CStr(YhCurRow), "k" + CStr(Je))
            End If
        End If
    Next
'    Debug.Print Now
    
    Dim i As Integer

    For i = 1 To coll.Count
        oValue = coll(i)
        Call GoLoop(oValue)
    Next
'    Debug.Print Now
    Call ChangeColorBlue
    Call SaveChange
'    Debug.Print Now
    If chkYdz.value = 0 Then
        chkYdz.value = 1
    End If
    IsRefresh = False
End Sub

Private Sub GoLoop(ByVal s As String)
    Dim SRow() As String
    Dim YhCurRow As Integer
    Dim DwCurRow As Integer
    Dim i As Integer
    Dim j As Integer
    Dim iStartDw As Integer
    SRow = Split(s, ",")
    If UBound(SRow) - LBound(SRow) > 0 Then
        iStartDw = LBound(SRow) + 1
        For i = LBound(SRow) To UBound(SRow) - iStartDw + 1
            If Left(SRow(i), 1) = "Y" Then
                YhCurRow = CInt(Mid(SRow(i), 2))
            Else
                Exit Sub
            End If
            For j = iStartDw To UBound(SRow)
                If Left(SRow(j), 1) = "D" Then
                    DwCurRow = CInt(Mid(SRow(j), 2))
                    Call Compare(YhCurRow, DwCurRow)
                Else
                    iStartDw = j + 1
                End If
            Next
        Next
    End If
End Sub
Private Sub Compare(ByVal YhCurRow As Integer, ByVal DwCurRow As Integer)
    If mfgDwrjz.TextMatrix(DwCurRow, 9) = "" Then
        YhdzdRq = Format(mfgYhdzd.TextMatrix(YhCurRow, 1), "yyyy-mm-dd")
        YhdzdJsfsCode = mfgYhdzd.TextMatrix(YhCurRow, 2)
        YhdzdBill = mfgYhdzd.TextMatrix(YhCurRow, 3)
        YhdzdFx = mfgYhdzd.TextMatrix(YhCurRow, 4)
        YhdzdJe = mfgYhdzd.TextMatrix(YhCurRow, 5)
        
        DwrjzPzrq = mfgDwrjz.TextMatrix(DwCurRow, 3)
        DwrjzJsfsCode = mfgDwrjz.TextMatrix(DwCurRow, 5)
        DwrjzBill = mfgDwrjz.TextMatrix(DwCurRow, 6)
        DwrjzFx = mfgDwrjz.TextMatrix(DwCurRow, 7)
        DwrjzJe = mfgDwrjz.TextMatrix(DwCurRow, 8)
        
        If GetDzCondition Then
            mfgDwrjz.TextMatrix(DwCurRow, 2) = mfgYhdzd.TextMatrix(YhCurRow, 0)
            mfgYhdzd.TextMatrix(YhCurRow, 6) = "○"
            mfgDwrjz.TextMatrix(DwCurRow, 9) = "○"
        End If
    End If
End Sub
'银行自动对账
Private Sub Yhzddz()
    Dim YhCurRow As Integer
    Dim DwCurRow As Integer
    
    IsRefresh = True
    For YhCurRow = 1 To mfgYhdzd.Rows - 1
        If mfgYhdzd.TextMatrix(YhCurRow, 6) = "" And mfgYhdzd.TextMatrix(YhCurRow, 1) <= _
            Format(frmYH_Yhdztj.dtpJzrq.value, "yyyy-mm-dd") Then
            
            YhdzdRq = Format(mfgYhdzd.TextMatrix(YhCurRow, 1), "yyyy-mm-dd")
            YhdzdJsfsCode = mfgYhdzd.TextMatrix(YhCurRow, 2)
            YhdzdBill = mfgYhdzd.TextMatrix(YhCurRow, 3)
            YhdzdFx = mfgYhdzd.TextMatrix(YhCurRow, 4)
            YhdzdJe = mfgYhdzd.TextMatrix(YhCurRow, 5)
            
            For DwCurRow = 1 To mfgDwrjz.Rows - 1
                If mfgDwrjz.TextMatrix(DwCurRow, 9) = "" And _
                    mfgDwrjz.TextMatrix(DwCurRow, 3) <= _
                    Format(frmYH_Yhdztj.dtpJzrq.value, "yyyy-mm-dd") Then
                    
                    DwrjzPzrq = mfgDwrjz.TextMatrix(DwCurRow, 3)
                    DwrjzJsfsCode = mfgDwrjz.TextMatrix(DwCurRow, 5)
                    DwrjzBill = mfgDwrjz.TextMatrix(DwCurRow, 6)
                    DwrjzFx = mfgDwrjz.TextMatrix(DwCurRow, 7)
                    DwrjzJe = mfgDwrjz.TextMatrix(DwCurRow, 8)
                    If GetDzCondition Then
                        mfgDwrjz.TextMatrix(DwCurRow, 2) = mfgYhdzd.TextMatrix(YhCurRow, 0)
                        mfgYhdzd.TextMatrix(YhCurRow, 6) = "○"
                        mfgDwrjz.TextMatrix(DwCurRow, 9) = "○"
                        Exit For
                    End If
                End If
            Next DwCurRow
        End If
    Next YhCurRow
    Call ChangeColorBlue
    Call SaveChange
    If chkYdz.value = 0 Then
        chkYdz.value = 1
    End If
    IsRefresh = False
End Sub

'得到银行对账条件
Private Function GetDzCondition() As Boolean
    GetDzCondition = True
    With frmYH_Yhdztj
        If .chkRqfw = 1 Then
            If DwrjzPzrq < CStr(Format(DateAdd("d", -10, CDate(YhdzdRq)), "yyyy-mm-dd")) And _
                DwrjzPzrq > CStr(Format(DateAdd("d", 10, CDate(YhdzdRq)), "yyyy-mm-dd")) Then
                GetDzCondition = False
                Exit Function
            End If
        End If
        If .chkJsfs = 1 Then
            If DwrjzJsfsCode <> YhdzdJsfsCode Then
                GetDzCondition = False
                Exit Function
            End If
        End If
        If .chkBill = 1 Then
            If DwrjzBill <> YhdzdBill Then
                GetDzCondition = False
                Exit Function
            End If
        End If
    End With
    If YhdzdJe <> DwrjzJe Or YhdzdFx = DwrjzFx Then
        GetDzCondition = False
    End If
End Function

'改变单元行颜色为蓝色
Private Sub ChangeColorBlue()
    Dim i As Integer
    Dim j As Integer
    Dim OldRowYh As Integer
    Dim OldRowDw As Integer
    
    IsRefresh = True
    OldRowYh = mfgYhdzd.Row
    With mfgYhdzd
        For i = 1 To .Rows - 1
            If Trim$("" & .TextMatrix(i, 6)) <> "" Then
                .Row = i
                For j = 0 To .Cols - 1
                    .Col = j
                    .CellBackColor = &HFFFFC0
                Next j
            End If
        Next i
    End With
    mfgYhdzd.Row = OldRowYh
    If mfgYhdzd.Row > 0 Then
        mfgYhdzd.Col = 6
    End If
    
    OldRowDw = mfgDwrjz.Row
    With mfgDwrjz
        For i = 1 To .Rows - 1
            If Trim$("" & .TextMatrix(i, 9)) <> "" Then
                .Row = i
                For j = 0 To .Cols - 1
                    .Col = j
                    .CellBackColor = &HFFFFC0
                Next j
            End If
        Next i
    End With
    mfgDwrjz.Row = OldRowDw
    If mfgDwrjz.Row > 0 Then
        mfgDwrjz.Col = 9
    End If
    IsRefresh = False
End Sub

'改变反对账单元行的颜色为白色
Private Sub ChangeColorWhite()
    Dim i As Integer
    Dim j As Integer
    Dim OldRowYh As Integer
    Dim OldRowDw As Integer
    
    IsRefresh = True
    OldRowYh = mfgYhdzd.Row
    With mfgYhdzd
        For i = 1 To .Rows - 1
            .Row = i
            If .TextMatrix(i, 6) = "" And .CellBackColor = &HFFFFC0 Then
                .Row = i
                For j = 0 To .Cols - 1
                    .Col = j