forma0.frm

用VB编写的家庭理财程序

         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00C00000&
      Height          =   180
      Left            =   960
      TabIndex        =   0
      Top             =   2880
      Width           =   405
   End
End
Attribute VB_Name = "FormA0"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
  
'     ┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━┓
'     ┃       FormA0      录入                                 ┃
'     ┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━┛

Const intCy1 = &HC0FFFF, intCx1 = &HC0E0FF

Dim intRo1 As Integer, intRos As Integer, Rqs As String
Dim Rq As String, Ym As String, intTs As Integer, Xmp As String, Bhp As Integer
Dim strDm As String, strSz As String, StrLb As String, strXm As String, strMc As String
Dim Xh As Integer, Sz As String, Lb As String, Mc As String, Bh As Integer, Bz As String
Dim Dj As Single, Sl As Single, Sr As Single, Zc As Single, Je As Single, Ye As Single
Dim Xhp As Integer, Rqp As String, Szp As String, Lbp As String, Mcp As String, Bzp As String
Dim Djp As Single, Slp As Single, Srp As Single, Zcp As Single, Jep As Single, Yep As Single
Dim strFs As String, blnXg As Boolean, blnSp As Boolean, blnBx As Boolean, blnBf As Boolean
Dim arrLb() As String, arrZm(), arrBh() As Integer
'


Private Sub Form_Load()
    
Db_fN2 = App.Path & StrDir & Db_Name2
StrCrq = Format(Date, "yyyy.mm.dd")

    If myF_ConnT(Db_fN2) = False Then Unload Me: Exit Sub        ' 连接库 T                                               ' 打开数据库 2
    
       StrT1 = "T_tm"                                            ' 条目表 MyRs1
       StrT2 = "T_zm"                                            ' 账目表 MyRs2
       StrT3 = "T_yf"                                            ' 报销表 MyRs3
    
    Label9 = StrCrq
    Ym = Left(StrCrq, 7)
    blnSp = True

    SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3
    
End Sub

Private Sub Form_Activate()
    
    If blnTc = True Then Unload Me: Exit Sub
    
    intRos = 30
    Call P_cmb1
    Call P_grid
    Call P_init
         Label1 = Month(Date) & "月"
         Text1(1) = " " & StrCrq
    Call P_tx3w                                        ' 显示控件 Combo2 (姓名)

End Sub

Private Sub Command6_Click()
    Frame1.Visible = True
    Label9 = Left(StrCrq, 7)
    intRos = 20
    With MSFlexGrid1
        .Top = 3120
        .Height = 225 * IIf(intTs > intRos, 21, intTs + 2) + 90
        .Col = 8: .ColWidth(8) = 2100 - IIf(.Rows > intRos, 270, 0)
         Label9.Top = .Top - 240
    End With
    blnSp = True
    Call P_init
    Command2.Enabled = False
    Command5.Visible = False
    Command6.Visible = False
    Call P_setb
    Text1(6).SetFocus
    blnSp = False
    strFs = "1"
    intRos = 20
End Sub

Private Sub P_init()
    strFs = "0"
    Call P_cmb2
    blnSp = True
    blnBx = False
    Bhp = 0
    For i = 3 To 7
        Text1(i) = ""
    Next
    Text1(3) = " " & StrLb
       For i = 3 To 7: Text1(i).Enabled = False: Next
       Option1(0).Enabled = False
       Option1(1).Enabled = False
       Combo1.Enabled = False
    Command1.Enabled = False
    Command2.Enabled = True
    Command3.Enabled = False
End Sub

Private Sub Option1_Click(Index As Integer)
    Call P_cmb1
    Text1(3).SetFocus
End Sub

Private Sub P_cmb1()
    strDm = "Lb"
    strSz = IIf(Option1(0), "收入", "支出")
       Sz = IIf(Option1(0), "s", "z")
    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]
       Combo1.Clear
       For i = 0 To N1 - 1
           arrLb(i, 1) = MyRs1![Mc]
           arrLb(i, 2) = MyRs1![Bz]
           Combo1.AddItem " " & MyRs1![Mc]
           MyRs1.MoveNext
       Next
       MyRs1.Close
       Combo1.Text = " " & StrLb
       Text1(2) = Lb
       Text1(3) = " " & StrLb
       Call P_tx3w
    End If
End Sub

Private Sub P_tx3w()
    If (StrLb Like "*工资*") Or (StrLb Like "*奖*") Or (StrLb Like "*医*") Or _
       (StrLb Like "*津贴*") Or (StrLb Like "*补*") Or (StrLb Like "*药*") Then
       Text1(3).Width = 2175
    Else
       Text1(3).Width = Combo2.Width
    End If
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
       strXm = MyRs0![Mc]
       Combo2.Clear
       For i = 1 To N0
           Combo2.AddItem " " & MyRs0![Mc]
           MyRs0.MoveNext
       Next
       MyRs0.Close
    End If
End Sub

Private Sub P_grid()
    Set MyRs2 = New Recordset                                    ' T_zm 表
    StrSQL = "SELECT * FROM " & StrT2 & _
             " WHERE Rq Like '" & Ym & "%' " & _
             " Order By Rq,Xh"
    MyRs2.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
       intTs = MyRs2.RecordCount                                 ' intTs: 条数
         If intTs = 0 Then
            Set MyRs0 = New Recordset
            StrSQL = "SELECT ye FROM " & StrT2 & " Order By Rq,Xh"
            MyRs0.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
               N0 = MyRs0.RecordCount
               If N0 > 0 Then
                  MyRs0.MoveLast
                  Ye = MyRs0![Ye]                                ' 余额
                  MyRs0.Close
               Else
                  Ye = 0
               End If
            intTs = 1
            Xh = 1
            StrSQL = "INSERT Into " & StrT2 & "( Rq,Xh,Sz,Lb,Mc,Dj,Sl,Sr,Zc,Ye,Bh,Bz ) " & _
                     " VALUES( '" & StrCrq & "'," & Xh & ",' ',' ','前余',0,0,0,0," & Ye & ",0,' ')"
            cnnTce.Execute StrSQL, , adCmdText
         Else
            MyRs2.MoveLast
            Xh = MyRs2![Xh]                                      ' 当月最后的序号
            Ye = MyRs2![Ye]
         End If
    With MSFlexGrid1
        .Clear
        .Top = IIf(Frame1.Visible, 3120, 360)
        .Rows = intTs + 1      ' IIf(intTs < 20, 20, intTs) + 1
        .Cols = 9
        .Height = 225 * IIf(intTs > intRos, intRos + 1, intTs + 2) + 90
        .Row = 0: .Col = 0: .Text = " 序 号":   .ColWidth(0) = 700
                  .Col = 1: .Text = " 日期":    .ColWidth(1) = 640
                  .Col = 2: .Text = "  名  称": .ColWidth(2) = 2060
                  .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) = 920
                  .Col = 8: .Text = "  备 注":  .ColWidth(8) = 2100 - IIf(.Rows > intRos + 1, 270, 0)
                   If intTs > 1 Then
                      MyRs2.MoveFirst
                      For i = 1 To intTs
                          Rq = MyRs2![Rq]
                          Sz = MyRs2![Sz]
                         .TextMatrix(i, 0) = i & "  "
                         .TextMatrix(i, 1) = "  " & Right(MyRs2![Rq], 2)
                         .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 MyRs2![Ye] < 0 Then
                                .Row = i: .Col = 7: .CellForeColor = &HFF&
                              End If
                         .TextMatrix(i, 8) = " " & MyRs2![Bz]  ' & " " & MyRs2![Lb]
                          MyRs2.MoveNext
                      Next
                   Else
                     .TextMatrix(1, 0) = "1  "
                     .TextMatrix(1, 2) = " 前余"
                     .TextMatrix(1, 7) = Format(Ye, " 0.00 ")
                      intTs = 1
                   End If
        .MergeCol(1) = True
        .MergeCells = flexMergeRestrictColumns                   ' 单元格合并
        .Visible = True
         Label9.Top = .Top + .Height + 200
         Command5.Top = Label9.Top
         Command6.Top = Label9.Top
    End With
    intRo1 = 1
    Call P_xxxx
    If Xh = 0 Then
    End If
End Sub

Private Sub P_xxxx()                                             ' 加一行
    Set MyRs0 = New Recordset
    StrSQL = "SELECT Xh,Sz,Lb,Ye FROM " & StrT2 & _
             " WHERE Rq Like '" & Ym & "%'" & _
             " Order By Rq,Xh"
    MyRs0.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
       intTs = MyRs0.RecordCount                                 ' intTs: 条数
    If intTs > 1 Then
       ReDim arrZm(intTs, 3)
          MyRs0.MoveFirst
          For i = 1 To intTs
              arrZm(i, 0) = MyRs0![Xh]                           ' 暂存记录
              arrZm(i, 1) = MyRs0![Sz]
              arrZm(i, 2) = MyRs0![Lb]
              arrZm(i, 3) = MyRs0![Ye]
              MyRs0.MoveNext
          Next
          MyRs0.Close
    End If
    With MSFlexGrid1
        .Rows = .Rows + 1
         k = .Row
        .Row = intRo1
            For j = 1 To .Cols - 1
               .Col = j: .CellBackColor = intCy1                 ' 颜色复原
            Next
        .Row = .Rows - 1
        .Col = 0: .Text = .Row & "  "
        .Col = 1: .Text = "  " & Right(StrCrq, 2)
            For j = 2 To .Cols - 1
                      .Col = j: .CellBackColor = intCx1          ' 设置颜色
                   Next
         intRo1 = .Row
        .Height = 225 * IIf(.Rows > intRos, intRos + 1, intTs + 2) + 90
        .Col = 8: .ColWidth(8) = 2100 - IIf(.Rows > intRos, 270, 0)
        .MergeCol(1) = True
        .MergeCells = flexMergeRestrictColumns                   ' 单元格合并
    End With
    If Frame1.Visible Then
       Command2.Enabled = True
       Command2.SetFocus
    Else
       Command6.SetFocus
    End If
End Sub

Private Sub P_grd2()
    Set MyRs3 = New Recordset                                    ' T_yf 表
    StrSQL = "SELECT * FROM " & StrT3 & _
             " Where Xm Like '%" & Xmp & "%' And Bx = 'A' " & _
             " Order By Bh"
    MyRs3.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
       N3 = MyRs3.RecordCount                                    ' N3: 条数
    If N3 > 0 Then
       ReDim arrBh(N3)
       With MSFlexGrid2
           .Clear
           .Rows = IIf(N3 > 3, N3, 3) + 1
           .Cols = 5
           .Height = 225 * .Rows + 90
           .Row = 0: .Col = 0: .Text = " 序号":     .ColWidth(0) = 600
                     .Col = 1: .Text = "  日  期":  .ColWidth(1) = 1200
                     .Col = 2: .Text = " 报销金额": .ColWidth(2) = 980
                     .Col = 3: .Text = "单据数量":  .ColWidth(3) = 820
                     .Col = 4: .Text = " 备 注 ":   .ColWidth(4) = 1100
            For i = 1 To N3
               .TextMatrix(i, 0) = i & "  ":          arrBh(i) = MyRs3![Bh]
               .TextMatrix(i, 1) = " " & MyRs3![Rq]
               .TextMatrix(i, 2) = Format(MyRs3![Je], "0.00 ")
               .TextMatrix(i, 3) = MyRs3![Sl] & "  "
               .TextMatrix(i, 4) = " " & MyRs3![Bz]
                MyRs3.MoveNext
            Next
            Frame2.Height = .Height
            Frame2.Visible = True
       End With
    Else
       Frame2.Visible = False
       MsgBox "  没有发现送交" & Xmp & "报销的相关记录 ... ", 48, "  请核查"
       Text1(3) = " " & StrLb
    End If
End Sub

Private Sub MSFlexGrid2_Click()                                  ' 取报销编号
    With MSFlexGrid2
         If .Row = 0 Or Trim(.TextMatrix(.Row, 2)) = "" Then Exit Sub
         Bhp = arrBh(.Row)
         Text1(6) = " " & Trim(.TextMatrix(.Row, 2))
    End With
    blnBx = True
    Frame2.Visible = False
    Text1(6).SetFocus
End Sub

Private Sub Combo1_Click()
    StrLb = Trim(Combo1.Text)
       Lb = arrLb(Combo1.ListIndex, 2)
      Bhp = 0
    Text1(2) = " " & Lb
    Call P_tx3w
    Text1(3) = " " & StrLb
    Text1(6).SetFocus
End Sub

Private Sub Combo2_Click()
    Xmp = Trim(Combo2.Text)
    Text1(3) = Combo1.Text & " " & Xmp
    If StrLb Like "*报销*" Then
       Call P_grd2
    Else
       Text1(3).SetFocus
    End If
End Sub

Private Sub Text1_GotFocus(Index As Integer)
    Text1(Index).SelStart = 0                                    ' 聚焦时反白显示
    Text1(Index).SelLength = Len(Text1(Index).Text)
End Sub

Private Sub Text1_Change(Index As Integer)                       ' 输入的合法性检验
    If blnSp Or Trim(Text1(Index)) = "" Then Exit Sub
    If Index = 1 Then
       Rqs = Trim(Text1(1))
       For i = 1 To Len(Rqs)
           c = Mid(Rqs, i, 1)
           If Not (IsNumeric(c) Or c = "." Or c = "," Or c = "-" Or c = "/") Then
              StrMsg = "  应输入合法的日期表达式，如:   " & vbCrLf & vbCrLf & _
                       "     05/4/6" & vbCrLf & vbCrLf & _
                       "     05-4-6" & vbCrLf & vbCrLf & _
                       "     2005.04.06" & vbCrLf
              MsgBox StrMsg, 48, "  请注意"
              Text1(1).SetFocus
              Exit Sub
           End If
       Next
    End If
       m = 0
    If Index = 4 Or Index = 5 Or Index = 6 Then
       If IsNumeric(Text1(Index)) Then
          If Val(Text1(Index)) < 0 Then m = 8
       Else
          m = 8
       End If
    End If
    If m <> 0 Then
       MsgBox "  应输入大于 0 的数字 ...  ", 48, "  请注意"
       Text1(Index) = ""
    Else                                                         ' 合法
       If strFs = "2" Then