formd6.frm

用VB编写的家庭理财程序

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

Private Sub P_init()
    strFs = "0"
    blnSp = True
       Option2(0).Enabled = True
       Option2(1).Enabled = True
    Label13 = "全部"
End Sub

Private Sub Check1_Click()
    Call P_grid
End Sub

Private Sub Option2_Click(Index As Integer)                ' ??   MsgBox Index
    If blnSp Then Exit Sub
    bytFs = Index
    If bytFs = 1 Then
       Label13 = "全部"
       Call P_grid
       Command1.Caption = "重整帐目"
    Else
       Command1.Caption = "确  认"
    End If
    Frame3.Visible = False
    Command1.Enabled = True
    Command1.SetFocus
End Sub

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

Private Sub Combo3_Click(Index As Integer)
    Text3(Index) = Combo3(Index).Text
End Sub

Private Sub Command1_Click()                                     ' 确认
    If Command1.Caption Like "*确*" Then
       If bytFs = 6 Then                                         ' 全部
          Frame3.Visible = False
          Call P_grid
          Option2(6).Enabled = False
          Exit Sub
       End If                                                    ' 重新整理   ??
       blnSp = True
       Frame3.Visible = True
          For i = 0 To 5: Text3(i) = "": Next
          Label13 = "全部"
          Call P_cmb3
       Select Case bytFs
              Case 0                                             ' 日期
                   Label12 = ""
              Case 1                                             ' 收入
                   Sz = "s"
       End Select
       blnSp = False
    Else                                                         ' 重整帐目
       With MSFlexGrid1
            If bytLx = 8 Then
               StrMsg = "    确实要将 " & Rqp & " " & Mcp & " 的信息修改存盘吗 ？  "
               If MsgBox(StrMsg, 1 + 32 + 0, "  请 确 认 ") <> 1 Then
                  Call Command3_Click
                  Exit Sub                                       ' 恢复
               Else
                  MyRs1.MoveFirst
                  If bytCol = 7 Then
                     MyRs1![Ye] = Val(.TextMatrix(1, 7))
                     MyRs1.Update
                  Else
                     Do While Not MyRs1.EOF
                        If Rqp = MyRs1![Rq] And Xhp = MyRs1![Xh] And Mcp = MyRs1![Mc] Then
                           If bytCol = 5 Then
                              MyRs1![Sr] = Val(.TextMatrix(intRow, 5))
                           Else
                              MyRs1![Zc] = Val(.TextMatrix(intRow, 6))
                           End If
                              MyRs1.Update
                           Exit Do
                        End If
                        MyRs1.MoveNext
                     Loop
                  End If
               End If
               bytLx = 0
            End If
            MyRs1.MoveFirst
               Yep = Val(.TextMatrix(1, 7))
            For i = 2 To intTs
                MyRs1.MoveNext
                Yep = Yep + Val(.TextMatrix(i, 5)) - Val(.TextMatrix(i, 6))
               .TextMatrix(i, 7) = Format(Yep, "0.00 ")
                MyRs1![Ye] = Yep
                MyRs1.Update
            Next
       End With
       
    End If
End Sub

Private Sub Command8_Click()                                     ' 继续
    
    If Text3(4) = "" Then Text3(3) = ""
    
    strTj = "": Sj1 = "": Sj2 = ""
    yyp = Trim(Text3(0))
    Mmp = Trim(Text3(1))
    Ddp = Trim(Text3(2))
       If yyp <> "" Then
          Sj1 = yyp
          If Mmp <> "" Then
             If Ddp = "" Then
                Sj1 = Sj1 & "." & Mmp
             Else
                Sj1 = Sj1 & "." & Mmp & "." & Ddp
             End If
          End If
       Else
          If Mmp <> "" Then
             Sj1 = Mmp
             If Ddp = "" Then
                
             Else
                Sj1 = Sj1 & "." & Ddp
             End If
          End If
       
       End If
    strTj = " Rq Like '" & Sj1 & "%'": StrMsg = Sj1
          
    If Trim(Text3(3)) <> "" Then                                 ' 时间区间
       yyp = Trim(Text3(3))
       Mmp = Trim(Text3(4))
       Ddp = Trim(Text3(5))
             Sj2 = yyp
             If Mmp <> "" Then
                If Ddp = "" Then
                   Sj2 = Sj2 & "." & Mmp       ' & ".31"
                Else
                   Sj2 = Sj2 & "." & Mmp & "." & Ddp
                End If
             End If
       If Sj1 <= Sj2 Then
          If Len(Sj2) < 5 Then
             Sj2 = Sj2 & ".12.31"
          Else
             If Len(Sj2) < 8 Then Sj2 = Sj2 & ".31"
          End If
          strTj = " Rq >= '" & Sj1 & "' And Rq <= '" & Sj2 & "'"
          StrMsg = Sj1 & " ～ " & Sj2
       Else
          If Len(Sj1) < 5 Then
             Sj1 = Sj1 & ".12.31"
          Else
             If Len(Sj1) < 8 Then Sj1 = Sj1 & ".31"
          End If
          strTj = " Rq >= '" & Sj2 & "' And Rq <= '" & Sj1 & "'"
          StrMsg = Sj2 & " ～ " & Sj1
       End If
    End If

    Label13 = "  " & StrMsg:    StrMsg = ""
    
    
    Select Case bytFs
           Case 0
                 
           Case 1
                strTj = strTj & " And Sz='s' And Lb='" & Lb & "'": StrMsg = StrLb
    End Select
'    Label13 = StrMsg
    Frame3.Visible = False
    bytFs = 0: Call P_grid                                       ' 显示
    Command1.Caption = "重整帐目"
End Sub

Private Sub Command7_Click()
    For i = 0 To 1: Option2(i).Value = False: Next
    Frame3.Visible = False
End Sub

Private Sub MSFlexGrid1_KeyPress(KeyAscii As Integer)            ' 选中一笔帐目
    If KeyAscii = 13 Then Call MSFlexGrid1_Click
End Sub

Private Sub MSFlexGrid1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Frame1.Top = IIf(y < 3000, 4320, y - Frame1.Height)
End Sub

Private Sub MSFlexGrid1_Click()                                  ' 选中一笔
    Frame1.Visible = False: bytLx = 0
    With MSFlexGrid1
         If Trim(.TextMatrix(.Row, 6)) = "" And Trim(.TextMatrix(.Row, 7)) = "" Then Exit Sub
         bytCol = .Col
         k = .Row
            For j = 1 To .Cols - 1
               .Col = j: .CellBackColor = intCx1                 ' 设置颜色
            Next
        .Row = intRow
            For j = 1 To .Cols - 1
               .Col = j: .CellBackColor = intCy1                 ' 颜色复原
            Next
         intRow = k
        .Row = k
            Xhp = arrZm(k, 0)                                    ' 序号 Xhp
            Szp = arrZm(k, 1)
            Rqp = Trim(.TextMatrix(k, 1))
            Mcp = Trim(.TextMatrix(k, 2))
            Djp = Val(.TextMatrix(k, 3))
            Slp = Val(.TextMatrix(k, 4))
            Jep = Val(.TextMatrix(k, IIf(Szp = "s", 5, 6)))
            Srp = Val(.TextMatrix(k, 5))
            Zcp = Val(.TextMatrix(k, 6))
            Yep = Val(.TextMatrix(k, 7))
            Bzp = Trim(.TextMatrix(k, 8))
         If bytCol < 5 And .Col > 7 Then Exit Sub
         If bytCol = 7 And .Row > 1 Then Exit Sub
         If bytCol = 7 And Mcp Like "*前余*" Then
            Label1 = "余 额：": Text1 = Format(Yep, " 0.00")
         Else
            If bytCol = 5 Then
               Label1 = "收 入：": Text1 = Format(Srp, " 0.00")
            Else
               Label1 = "支 出：": Text1 = Format(Zcp, " 0.00")
            End If
         End If
         Frame1.Visible = True: bytLx = 8
         Text1.SetFocus
    End With
End Sub

Private Sub Text1_Change()
    Command1.Enabled = False
    Command2.Enabled = False
    If IsNumeric(Text1) Then
       If bytCol = 7 Then
          Command2.Enabled = True
       Else
          If Val(Text1) < 0 Then
             MsgBox "  应输入不小于 0 的数字 ...  ", 48, "  请注意"
             Text1 = ""
          Else
             Command2.Enabled = True
          End If
       End If
    Else
       MsgBox "  应输入大于 0 的数字 ...  ", 48, "  请注意"
       Text1 = ""
    End If
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
       Command2.SetFocus
    End If
End Sub

Private Sub Command2_Click()                                     ' 确认
    With MSFlexGrid1
        .TextMatrix(intRow, bytCol) = Format(Val(Text1), "0.00 ")
    End With
    Frame1.Visible = False
    Command1.Enabled = True
    Command1.SetFocus
End Sub

Private Sub Command3_Click()                                     ' 放弃
    With MSFlexGrid1
         Select Case bytCol                                      ' 恢复
                Case 5
                    .TextMatrix(intRow, 5) = Format(Srp, "0.00 ")
                Case 6
                    .TextMatrix(intRow, 6) = Format(Zcp, "0.00 ")
                Case 7
                    .TextMatrix(intRow, 7) = Format(Yep, "0.00 ")
         End Select
    End With
    Command1.Enabled = True
    Frame1.Visible = False: bytLx = 0
End Sub

Private Sub Command5_Click()                                     ' 退出
    Unload Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
 On Error Resume Next                                ' 关闭记录集，释放对象
    MyRs1.Close: Set MyRs1 = Nothing
    MyRs3.Close: Set MyRs3 = Nothing
    MyDb2.Close: Set MyDb2 = Nothing
End Sub