formc1.frm

用VB编写的家庭理财程序

       N5 = MyRs5.RecordCount: ReDim arrSl(N5, 2)
       For i = 1 To N5
           arrSl(i, 0) = MyRs5![Mc]
           arrSl(i, 1) = MyRs5![Jc]
           arrSl(i, 2) = MyRs5![Bz]
           MyRs5.MoveNext
       Next
       MyRs5.Close
    Else
       MsgBox "  没有发现类别信息 ...  ", 48, "  请注意"
    End If
End Sub

Private Sub Check1_Click()
    If bytGrd = "2" Then Exit Sub
    If bytGrd = "1" Then
       Call P_grd1
    Else
       Call P_grd0
    End If
End Sub

Private Sub P_grd1()
    bytGrd = "1"
    Set MyRs2 = New Recordset                                    ' T_zm 表
    If Check1 = 0 Then
       StrSQL = "SELECT * FROM " & StrT2 & " Order By Rq,Xh"
    Else
       StrSQL = "SELECT * FROM " & StrT2 & " Order By Rq Desc,Xh Desc"
    End If
    MyRs2.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
       intTs = MyRs2.RecordCount                                 ' intTs: 条数
    With MSFlexGrid1
        .Clear
        .Rows = IIf(intTs < intRou, intRou, intTs) + 1
        .Cols = 9
        .Height = 225 * (intRou + 1) + 90
        .Row = 0: .Col = 0: .Text = " 序号":    .ColWidth(0) = 600
                  .Col = 1: .Text = " 日 期":   .ColWidth(1) = 1140
                  .Col = 2: .Text = "  名  称": .ColWidth(2) = 1750
                  .Col = 3: .Text = "  单价 ":  .ColWidth(3) = 820
                  .Col = 4: .Text = " 数量 ":   .ColWidth(4) = 620
                  .Col = 5: .Text = "  收 入 ": .ColWidth(5) = 920
                  .Col = 6: .Text = "  支 出 ": .ColWidth(6) = 920
                  .Col = 7: .Text = "  余 额 ": .ColWidth(7) = 960
                  .Col = 8: .Text = "  备 注":  .ColWidth(8) = 1300 - IIf(intTs < intRou, 0, 270)
                   If intTs > 0 Then
                      ReDim arrZm(intTs, 2)
                      MyRs2.MoveFirst
                      For i = 1 To intTs
                          arrZm(i, 0) = MyRs2![Xh]               ' 暂存记录
                          arrZm(i, 1) = MyRs2![Sz]
                          arrZm(i, 2) = MyRs2![Lb]
                          Rq = MyRs2![Rq]
                          Sz = MyRs2![Sz]
                         .TextMatrix(i, 0) = i & " "
                         .TextMatrix(i, 1) = " " & Rq
                         .TextMatrix(i, 2) = " " & MyRs2![Mc]
                         .TextMatrix(i, 3) = IIf(MyRs2![Dj] > 0, Format(MyRs2![Dj], "0.00 "), "")
                         .TextMatrix(i, 4) = IIf(MyRs2![Sl] > 0, MyRs2![Sl] & " ", "")
                         .TextMatrix(i, 5) = IIf(Sz = "s", Format(MyRs2![Sr], "0.00 "), "")
                         .TextMatrix(i, 6) = IIf(Sz = "z", Format(MyRs2![Zc], "0.00 "), "")
                         .TextMatrix(i, 7) = Format(MyRs2![Ye], "0.00 ")
                             If Val(MyRs2![Ye]) < 0 Then .Row = i: .Col = 7: .CellForeColor = &HFF&
                         .TextMatrix(i, 8) = " " & MyRs2![Bz]  ' & " " & MyRs2![Lb]
                          MyRs2.MoveNext
                      Next
                      MyRs2.Close
                   End If
        .MergeCol(1) = True
        .MergeCells = flexMergeRestrictColumns                   ' 单元格合并
        .Visible = True
    End With
    Label13 = "全部"
End Sub

Private Sub Check3_Click()
    Call P_grd2
    If MSFlexGrid3.Visible Then
       Ye = Val(MSFlexGrid1.TextMatrix(intRo1 - 1, 4))
       Ny = Trim(MSFlexGrid1.TextMatrix(intRo1, 1))
       Call P_grd3
    End If
End Sub

Private Sub P_grd2()                                             ' 按月统计
    bytGrd = "2"
    Set MyRs4 = New Recordset
    StrSQL = "SELECT Rq,Ye FROM " & StrT2 & " Where Mc Like '%前余%' Order By Rq"
    MyRs4.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
       N4 = MyRs4.RecordCount                                    ' N4: 月数
    With MSFlexGrid1
        .Clear
        .Rows = IIf(N4 + 5 < intRou, intRou, N4 + 5) + 1
        .Height = 225 * (intRou + 1) + 90
        .Cols = 6
        .Row = 0: .Col = 0: .Text = " 序号":      .ColWidth(0) = 600
                  .Col = 1: .Text = "  日 期":    .ColWidth(1) = 900
                  .Col = 2: .Text = "   收  入 ": .ColWidth(2) = 1200
                  .Col = 3: .Text = "   支  出 ": .ColWidth(3) = 1200
                  .Col = 4: .Text = "   余  额 ": .ColWidth(4) = 1200
                  .Col = 5: .Text = "  备 注":    .ColWidth(5) = 4200 - IIf(N4 + 5 < intRou, 0, 270)
         Ye = MyRs4![Ye]
        .TextMatrix(1, 5) = " 前余"
        .TextMatrix(1, 4) = Format(Ye, "0.00 ")
         m = 0: sigSr = 0: sigZc = 0
         For i = 2 To N4 + 1
             Ny = Left(MyRs4![Rq], 7)
            .TextMatrix(i, 0) = i - 1 & "  "
            .TextMatrix(i, 1) = " " & Ny
             Set MyRs2 = New Recordset                           ' 月收支
             StrSQL = "SELECT Sr,Zc,Ye FROM " & StrT2
             If Check3.Value = 0 Then
                StrSQL = StrSQL & " Where Rq Like '" & Ny & "%'"
             Else
                StrSQL = StrSQL & " Where Rq Like '" & Ny & "%'" & _
                                  "   And Mc Not Like '%医药费报销%' " & _
                                  "   And Bz Not Like '%B%'"
             End If
             StrSQL = StrSQL & " Order By Xh"
             MyRs2.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
                N2 = MyRs2.RecordCount
                If N2 > 1 Then
                   MyRs2.MoveNext
                   Sr = 0: Zc = 0
                   Do While Not MyRs2.EOF
                      Sr = Sr + MyRs2![Sr]
                      Zc = Zc + MyRs2![Zc]
                      MyRs2.MoveNext
                   Loop
                   MyRs2.Close
                   Ye = Ye + Sr - Zc
                  .TextMatrix(i, 2) = Format(Sr, "0.00 ")
                  .TextMatrix(i, 3) = Format(Zc, "0.00 ")
                  .TextMatrix(i, 4) = Format(Ye, "0.00 ")
                      If Val(Ye) < 0 Then .Row = i: .Col = 4: .CellForeColor = &HFF&
                   m = m + 1
                   sigSr = sigSr + Sr: sigZc = sigZc + Zc
                Else
                  .TextMatrix(i, 4) = Format(Ye, "0.00 ")
                      If Val(Ye) < 0 Then .Row = i: .Col = 4: .CellForeColor = &HFF&
                End If
             MyRs4.MoveNext
         Next
         MyRs4.Close
        .TextMatrix(i + 1, 1) = "    平均"
        .TextMatrix(i + 1, 2) = Format(sigSr / m, "0.00 ")
        .TextMatrix(i + 1, 3) = Format(sigZc / m, "0.00 ")
        .TextMatrix(i + 2, 1) = "    累计"
        .TextMatrix(i + 2, 2) = Format(sigSr, "0.00 ")
        .TextMatrix(i + 2, 3) = Format(sigZc, "0.00 ")
        .Visible = True
    End With
    Label13 = "按月统计收支 ": Check3.Visible = True
End Sub

Private Sub P_grd3()                                             ' 某月统计
    StrSQL = "SELECT * FROM " & StrT2
        If Check3.Value = 0 Then
           StrSQL = StrSQL & " Where Rq Like '" & Ny & "%'"
        Else
           StrSQL = StrSQL & " Where Rq Like '" & Ny & "%'" & _
                             "   And Mc Not Like '%医药费报销%' " & _
                             "   And Bz Not Like '%B%'"
        End If
    StrSQL = StrSQL & " Order By Xh"
    Set MyRs2 = New Recordset
    MyRs2.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
       N2 = MyRs2.RecordCount                                    ' n2: 记录数
       If N2 < 0 Then Exit Sub
    With MSFlexGrid3
        .Clear
        .Rows = IIf(N2 + 3 < intRou, intRou, N2 + 3) + 1
        .Height = 225 * (intRou + 1) + 90
        .Width = MSFlexGrid1.Width
        .Cols = 9
        .Row = 0: .Col = 0: .Text = " 序号":    .ColWidth(0) = 600
                  .Col = 1: .Text = " 日 期":   .ColWidth(1) = 1140
                  .Col = 2: .Text = "  名  称": .ColWidth(2) = 1750
                  .Col = 3: .Text = "  单价 ":  .ColWidth(3) = 820
                  .Col = 4: .Text = " 数量 ":   .ColWidth(4) = 620
                  .Col = 5: .Text = "  收 入 ": .ColWidth(5) = 920
                  .Col = 6: .Text = "  支 出 ": .ColWidth(6) = 920
                  .Col = 7: .Text = "  余 额 ": .ColWidth(7) = 960
                  .Col = 8: .Text = "  备 注":  .ColWidth(8) = 1300 - IIf(N2 + 3 < intRou, 0, 270)
         MyRs2.MoveFirst
         Sr = 0: Zc = 0
         For i = 1 To N2
             Rq = MyRs2![Rq]
             Sz = MyRs2![Sz]
                  Ye = Ye + MyRs2![Sr] - MyRs2![Zc]
                  Sr = Sr + MyRs2![Sr]
                  Zc = Zc + MyRs2![Zc]
            .TextMatrix(i, 0) = i & " "
            .TextMatrix(i, 1) = " " & Rq
            .TextMatrix(i, 2) = " " & MyRs2![Mc]
            .TextMatrix(i, 3) = IIf(MyRs2![Dj] > 0, Format(MyRs2![Dj], "0.00 "), "")
            .TextMatrix(i, 4) = IIf(MyRs2![Sl] > 0, MyRs2![Sl] & " ", "")
            .TextMatrix(i, 5) = IIf(Sz = "s", Format(MyRs2![Sr], "0.00 "), "")
            .TextMatrix(i, 6) = IIf(Sz = "z", Format(MyRs2![Zc], "0.00 "), "")
            .TextMatrix(i, 7) = Format(Ye, "0.00 ")
                If Val(Ye) < 0 Then .Row = i: .Col = 7: .CellForeColor = &HFF&
            .TextMatrix(i, 8) = " " & MyRs2![Bz]
             MyRs2.MoveNext
         Next
             MyRs2.Close
        .TextMatrix(i + 1, 2) = " " & Ny & " 累计"
        .TextMatrix(i + 1, 5) = Format(Sr, "0.00 ")
        .TextMatrix(i + 1, 6) = Format(Zc, "0.00 ")
        .MergeCol(1) = True
        .MergeCells = flexMergeRestrictColumns                   ' 单元格合并
        .Visible = True
    End With
    Command2.Visible = True
    StrMsg = Label13
    Label13 = Ny & " 收支记录 "
End Sub

Private Sub Command2_Click()
    MSFlexGrid3.Visible = False
    Command2.Visible = False
    Label13 = "按月统计收支 "
End Sub

Private Sub P_grd4()
    strDm = "Lb"
    StrSQL = "Select * From " & StrT1 & _
             " Where Dm Like '" & strDm & "%' And Jc Like '" & Sz & "%'" & _
             " Order By Xh"
    Set MyRs1 = New Recordset
    MyRs1.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
    If MyRs1.RecordCount > 0 Then
       N1 = MyRs1.RecordCount: ReDim arrLb(N1, 2)
       StrLb = "" ' MyRs1![Mc]
          Lb = "" ' MyRs1![Bz]
       Combo2.Visible = False
          With MSFlexGrid2
              .Clear
              .Rows = IIf(N1 < 8, 8, N1) + 1
              .Cols = 3
              .Height = 225 * 9 + 90
              .Row = 0: .Col = 0: .Text = "序号":    .ColWidth(0) = 500
                        .Col = 1: .Text = "  名 称": .ColWidth(1) = 1160
                        .Col = 2: .Text = " 备注":   .ColWidth(2) = 900 - IIf(.Rows > 9, 270, 0)
               MyRs1.MoveFirst
               For i = 1 To N1
                   arrLb(i, 1) = Trim(MyRs1![Mc])
                   arrLb(i, 2) = MyRs1![Bz]
                  .TextMatrix(i, 0) = i & "  "
                  .TextMatrix(i, 1) = " " & arrLb(i, 1)
                   MyRs1.MoveNext
               Next
              .TextMatrix(1, 2) = " √"
              .Visible = True
          End With
          Check2.Visible = True
       MyRs1.Close
    End If
    Label12 = "请选择类别：":
    Label12.Visible = True
End Sub

Private Sub Check2_Click()                                      ' 全选
    With MSFlexGrid2
         If Check2.Value = 0 Then
             For i = 1 To N1
                .Row = i: .TextMatrix(i, 2) = ""
                 For j = 1 To .Cols - 1
                    .Col = j: .CellBackColor = intCy2           ' 颜色复原
                 Next
             Next
         Else
             For i = 1 To N1
                .Row = i: .TextMatrix(i, 2) = " √"
                 For j = 1 To .Cols - 1
                    .Col = j: .CellBackColor = intCx2           ' 设置颜色
                 Next
             Next
         End If
    End With
End Sub

Private Sub MSFlexGrid2_Click()
    With MSFlexGrid2
         If .TextMatrix(.Row, 2) Like "*√*" Then
            .TextMatrix(.Row, 2) = ""
             For j = 1 To .Cols - 1
                .Col = j: .CellBackColor = intCy2                ' 颜色复原
             Next
         Else
            .TextMatrix(.Row, 2) = " √"
             For j = 1 To .Cols - 1
                .Col = j: .CellBackColor = intCx2                ' 设置颜色
             Next
         End If
    End With
End Sub

Private Sub P_init()
    strFs = "0"
    bytFs = 0
    blnSp = True
    For i = 1 To 7: Text1(i) = "": Next
       Option1(0).Enabled = False
       Option1(1).Enabled = False
    StrLb = "" ' MyRs1![Mc]
       Lb = "" ' MyRs1![Bz]
End Sub

Private Sub Option2_Click(Index As Integer)
    If blnSp Then Exit Sub
    bytFs = Index
    Frame3.Visible = False
    Command1.Caption = "确  认"
    Command1.Enabled = True
    Command1.SetFocus
End Sub

Private Sub P_cmb2()                                          ' 姓名选择
    strDm = "Xm"
    StrSQL = "Select * From " & StrT1 & " Where Dm Like '" & strDm & "%' Order By Xh"
    Set MyRs0 = New Recordset
    MyRs0.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
    If MyRs0.RecordCount > 0 Then
       N0 = MyRs0.RecordCount
       With Combo2
           .Clear
           .AddItem " "
            For i = 1 To N0
               .AddItem " " & MyRs0![Mc]
                MyRs0.MoveNext
            Next
           .Visible = True
       End With
       MSFlexGrid2.Visible = False: Check2.Visible = False
       Label12.Visible = True
       MyRs0.Close
    End If
    Label12 = "请选择姓名："
End Sub

Private Sub P_cmb3()
    StrSQL = "Select Left(Rq,4) As Yy From " & StrT2 & " Order By Rq"
    Set MyRs1 = New Recordset
    MyRs1.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
       If MyRs1.RecordCount > 0 Then
          yyp = "":                           Text3(3) = " "
          Text3(0) = " " & Left(StrCrq, 4):   Combo3(3).Clear
          Combo3(0).Clear:                    Combo3(3).AddItem "  "
          Do While Not MyRs1.EOF
             If yyp <> MyRs1![yy] Then
                yyp = MyRs1![yy]
                Combo3(0).AddItem " " & yyp:  Combo3(3).AddItem " " & yyp
             End If
             MyRs1.MoveNext
          Loop
          MyRs1.Close
       Else
          Text3(0) = " ":                     Text3(3) = " "
       End If
    StrSQL = "Select Mid(Rq,6,2) As Mm From " & StrT2 & " Order By Rq"
    Set MyRs1 = New Recordset
    MyRs1.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
       If MyRs1.RecordCount > 0 Then
          Mmp = ""
          Text3(1) = " " & Mid(StrCrq, 6, 2): Text3(4) = " "
          Combo3(1).Clear:                    Combo3(4).Clear
          Combo3(1).AddItem "  ":             Combo3(4).AddItem "  "
          Do While Not MyRs1.EOF
             If Mmp <> MyRs1![Mm] Then
                Mmp = MyRs1![Mm]
                Combo3(1).AddItem " " & Mmp:  Combo3(4).AddItem " " & Mmp
             End If
             MyRs1.MoveNext
          Loop
          MyRs1.Close
       Else
          Text3(1) = " ":                     Text3(4) = " "
       End If
    StrSQL = "Select Right(Rq,2) As Dd From " & StrT2 & " Order By Rq"
    Set MyRs1 = New Recordset
    MyRs1.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
       If MyRs1.RecordCount > 0 Then
          Ddp = "":
          Text3(2) = " ":                     Text3(5) = " "
          Combo3(2).Clear:                    Combo3(5).Clear
          Combo3(2).AddItem "  ":             Combo3(5).AddItem "  "
          Do While Not MyRs1.EOF
             If Ddp <> MyRs1![Dd] Then
                Ddp = MyRs1![Dd]