formb0.frm

用VB编写的家庭理财程序

                  .Col = 4: .Text = " 数量 ":   .ColWidth(4) = 620
                  .Col = 5: .Text = "  收 入 ": .ColWidth(5) = 980
                  .Col = 6: .Text = "  支 出 ": .ColWidth(6) = 980
                  .Col = 7: .Text = "  备 注":  .ColWidth(7) = 1160 - IIf(.Rows > intRs3 + 1, 270, 0)
                   If N0 > 0 Then
                      ReDim arrZm(N0, 3)
                      MyRs0.MoveFirst
                      Srp = 0: Zcp = 0
                      For i = 1 To N0
                          Rq = MyRs0![Rq]
                          Sz = MyRs0![Sz]
                          arrZm(i, 0) = MyRs0![Xh]                ' 暂存记录
                          arrZm(i, 1) = MyRs0![Sz]
                          arrZm(i, 2) = MyRs0![Lb]
                          arrZm(i, 3) = MyRs0![Rq]
                         .TextMatrix(i, 0) = i & "  "
                         .TextMatrix(i, 1) = " " & Rq
                         .TextMatrix(i, 2) = " " & MyRs0![Mc]
                         .TextMatrix(i, 3) = IIf(MyRs0![Dj] > 0, Format(MyRs0![Dj], "0.00 "), "")
                         .TextMatrix(i, 4) = IIf(MyRs0![Sl] > 0, MyRs0![Sl] & " ", "")
                         .TextMatrix(i, 5) = IIf(Sz = "s", Format(MyRs0![Sr], "0.00 "), "")
                         .TextMatrix(i, 6) = IIf(Sz = "z", Format(MyRs0![Zc], "0.00 "), "")
                         .TextMatrix(i, 7) = " " & MyRs0![Bz]
                          Srp = Srp + MyRs0![Sr]
                          Zcp = Zcp + MyRs0![Zc]
                          MyRs0.MoveNext
                      Next
                         .TextMatrix(i + 1, 2) = " 累计"
                         .TextMatrix(i + 1, 5) = IIf(Srp > 0, Format(Srp, "0.00 "), "")
                         .TextMatrix(i + 1, 6) = Format(Zcp, "0.00 ")
                   End If
        .MergeCol(1) = True
        .MergeCells = flexMergeRestrictColumns                   ' 单元格合并
        .Visible = True
    End With
    Text1(2).Enabled = True
    Text1(3).Enabled = True
End Sub

Private Sub MSFlexGrid3_Click()
    With MSFlexGrid3
         If Trim(.TextMatrix(.Row, 1)) = "" Then Exit Sub
        .Col = 1
         If .TextMatrix(.Row, 7) Like "*√*" Then
             m = m - 1
            .TextMatrix(.Row, 7) = ""
             For j = 1 To .Cols - 1
                .Col = j: .CellBackColor = intCy3                ' 颜色复原
             Next
             Text1(0) = " " & Val(Text1(0)) - 1
             Text1(1) = " " & Format(Val(Text1(1)) - Val(.TextMatrix(.Row, 6)), "0.00")
         Else
             m = m + 1
            .TextMatrix(.Row, 7) = " √"
             For j = 1 To .Cols - 1
                .Col = j: .CellBackColor = intCx3                ' 设置颜色
             Next
             Text1(0) = " " & Val(Text1(0)) + 1
             Text1(1) = " " & Format(Val(Text1(1)) + Val(.TextMatrix(.Row, 6)), "0.00")
         End If
    End With
    Command3.Enabled = IIf(m > 0, True, False)
End Sub

Private Sub Command7_Click()                                     ' 报销
    StrMsg = "  确实要将 " & Xmp & " " & Sjp & _
             " 的医药费 " & Trim(Text1(1)) & " 元报销冲帐吗 ？  "
    If MsgBox(StrMsg, 1 + 32 + 0, "  请 确 认 ") <> 1 Then Exit Sub

    Sl = Val(Text1(0))
    Je = Val(Text1(1))
    Rq = Trim(Text1(3))
    Ym = Left(StrCrq, 7)
    Set MyRs4 = New Recordset                                    ' T_zm 表
    StrSQL = "SELECT * FROM " & StrT2 & _
             " WHERE Rq Like '" & Ym & "%' " & _
             " Order By Rq,Xh"
    MyRs4.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
       MyRs4.MoveLast
          Xh = MyRs4![Xh] + 1                                   ' 当月最后的序号
          Ye = Format(MyRs4![Ye] + Jep, "0.00")
       MyRs4.Close
    StrSQL = "INSERT Into " & StrT2 & "( Rq,Xh,Sz,Lb,Mc,Dj,Sl,Sr,Zc,Ye,Bh,Bz) " & _
             "  VALUES ( '" & Rq & "'," & Xh & "," & "'s','B','医药费报销 " & Xmp & "', 0,0," & _
                              Jep & ",0," & Ye & "," & Bhp & ",' ')"
    cnnTce.Execute StrSQL, , adCmdText
    Set MyRs4 = New Recordset                                    ' T_yf 表
    StrSQL = "SELECT * FROM " & StrT3 & " Where Bh = " & Bhp
    MyRs4.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
       N4 = MyRs4.RecordCount
       If N4 > 0 Then
          MyRs4![Bx] = "B"                                       ' 置报销标志
          MyRs4![Bz] = Rq
          MyRs4.Update
          MyRs4.Close
       Else
          MsgBox "  Not Find Datas ...  ", 48, "  Error": Exit Sub
       End If
    Set MyRs4 = New Recordset                                    ' T_zm 表
    StrSQL = "SELECT * FROM " & StrT2 & _
             " Where Bh = " & Bhp & " And Zc > 0 "
    MyRs4.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
       N4 = MyRs4.RecordCount
       If N4 > 0 Then
          Do While Not MyRs4.EOF
             MyRs4![Bz] = "B" & Bhp & " " & MyRs4![Bz]
             MyRs4.Update
             MyRs4.MoveNext
          Loop
          MyRs4.Close
       Else
          MsgBox "  Not Find Datas ...  ", 48, "  Error": Exit Sub
       End If
    MSFlexGrid1.TextMatrix(intRo1, 5) = "  √"
    Command7.Enabled = False
End Sub

Private Sub Command1_Click()                                     ' 存盘
    With MSFlexGrid2                                             ' 取起止时间
         For i = N2 To 1 Step -1
             If .TextMatrix(i, 8) Like "*√*" Then
                 Sj = Trim(.TextMatrix(i, 2)) & "～": Exit For
             End If
         Next
         For i = 1 To N2
             If .TextMatrix(i, 8) Like "*√*" Then
                 Sj = Sj & Trim(.TextMatrix(i, 2)):   Exit For
             End If
         Next
    End With
    Sl = Val(Text1(0))
    Je = Val(Text1(1))
    Rq = Trim(Text1(2))
    Bx = "A"
    Bz = Trim(Text1(3)): If Bz = "" Then Bz = " "
    
    If strFs = "3" Then
       
       StrMsg = "  确实要将 " & Xm & " 的医药费汇总单据送交报销吗 ？  "
       If MsgBox(StrMsg, 1 + 32 + 0, "  请 确 认 ") <> 1 Then Exit Sub
       Bh = Bh + 1
       StrSQL = "INSERT Into " & StrT3 & "( Bh,Xm,Sj,Je,Sl,Bx,Rq,Bz) " & _
                "  VALUES ( '" & Bh & "','" & Xm & "','" & Sj & "'," & Je & "," & _
                                 Sl & ",'" & Bx & "','" & Rq & "','" & Bz & " ')"
       cnnTce.Execute StrSQL, , adCmdText
       N3 = N3 + 1: arrBh(N3, 0) = Bh
                    arrBh(N3, 1) = Bx
                    arrBh(N3, 2) = Rq
       With MSFlexGrid2
            For i = 1 To N2
                If .TextMatrix(i, 8) Like "*√*" Then
                    Xh2 = arrZm(i, 0)
                    Rq2 = arrZm(i, 3)
                    MyRs2.MoveFirst
                    For j = 1 To N2
                        If MyRs2![Rq] = Rq2 And MyRs2![Xh] = Xh2 Then
                           MyRs2![Bh] = Bh
                           MyRs2.Update: Exit For
                        End If
                        MyRs2.MoveNext
                    Next
                End If
           Next
       End With
       With MSFlexGrid1
           .TextMatrix(N3, 0) = Bh & "  "
           .TextMatrix(N3, 1) = " " & Xm
           .TextMatrix(N3, 2) = " " & Sj
           .TextMatrix(N3, 3) = Format(Je, "0.00 ")
           .TextMatrix(N3, 4) = Sl & " "
           .TextMatrix(N3, 6) = " " & Rq
           .Rows = IIf(N3 + 2 < intRs1, intRs1, N3 + 2) + 1
           .ColWidth(7) = 1160 - IIf(.Rows > intRs1 + 1, 270, 0)
           .TextMatrix(Bh + 2, 1) = " 累计"
           .TextMatrix(Bh + 2, 3) = Format(Val(.TextMatrix(Bh + 1, 3)) + Je, "0.00 ")
           .TextMatrix(Bh + 2, 4) = Val(.TextMatrix(Bh + 1, 4)) + Sl & " "
           .TextMatrix(Bh + 1, 1) = ""
           .TextMatrix(Bh + 1, 3) = ""
           .TextMatrix(Bh + 1, 4) = ""
       End With
       
    Else                                                           ' 修改
       
       blnXg = False
          If Rq <> Rqp Then blnXg = True ': MsgBox "rq:" & rq & "-" & rqp                         ' 有改动 ?
          If Sz <> Szp Then blnXg = True ': MsgBox "sz:" & sz & "-" & szp
          If Lb <> Lbp Then blnXg = True ': MsgBox "lb:" & Lb & "-" & Lbp
          If Mc <> Mcp Then blnXg = True ': MsgBox "mc:" & mc & "-" & mcp
          If Dj <> Djp Then blnXg = True ': MsgBox "dj:" & dj & "-" & Lbp
          If Sl <> Slp Then blnXg = True ': MsgBox "sl:" & sl & "-" & Tsp
          If Je <> Jep Then blnXg = True ': MsgBox "je:" & je & "-" & Lbp
          If Bz <> Bzp Then blnXg = True ': MsgBox "bz:" & bz & "-" & bzp
       If blnXg Then
          StrMsg = "  确实要将第 " & intRo1 & " 行的相关资料修改存盘吗 ？  "
          If MsgBox(StrMsg, 1 + 32 + 0, "  请 确 认 ") = 1 Then
             StrSQL = "SELECT * FROM " & StrT2 & _
                      " WHERE Rq='" & Rq & "' And Xh=" & Xh2
             Set MyRs0 = New Recordset
             MyRs0.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
             If MyRs0.RecordCount > 0 Then
                If Rq <> Rqp Then MyRs0![Rq] = Rq
                If Sz <> Szp Then MyRs0![Sz] = Sz
                If Lb <> Lbp Then MyRs0![Lb] = Lb
                If Mc <> Mcp Then MyRs0![Mc] = Mc
                If Dj <> Djp Then MyRs0![Dj] = Dj
                If Sl <> Slp Then MyRs0![Sl] = Sl
                If Je <> Jep Then
                   MyRs0![Sr] = IIf(Sz = "s", Je, 0)
                   MyRs0![Zc] = IIf(Sz = "z", Je, 0)
                End If
                If Bz <> Bzp Then MyRs0![Bz] = Bz
                MyRs0.Update
                MyRs0.Close
             Else
                MsgBox "  Not Find Datas ....  ", 48, "  Error": Exit Sub
             End If
          '   Call P_grid
          End If
       End If
    
    End If
    
    Call P_init

End Sub

Private Sub Command2_Click()                                         ' 删除  ??
    StrMsg = "  确实要将第 " & intRo1 & " 行的相关资料删除吗 ？  "
    If MsgBox(StrMsg, 1 + 32 + 0, "  请 确 认 ") = 1 Then
       StrSQL = "DELETE FROM " & StrT2 & _
                " WHERE Rq='" & Rq & "' And Xh=" & Xh2
       ' cnnTce.Execute StrSQL, , adCmdText
       
       Call P_grd2
    End If
End Sub

Private Sub Command3_Click()                                         ' 追加报销
    Rq = Trim(Text1(2))
    StrMsg = "  确实要将 " & Xmp & " 的医药费追加到第 " & intRo1 & " 号报销单吗 ？  "
    If MsgBox(StrMsg & " " & Sj, 1 + 32 + 0, "  请 确 认 ") <> 1 Then Exit Sub
       
         For i = 1 To N0
             If MSFlexGrid3.TextMatrix(i, 7) Like "*√*" Then
                Sj = Left(Sjp, 10) & "～" & Trim(MSFlexGrid3.TextMatrix(i, 1)): Exit For
             End If
         Next
    Sl = Val(Text1(0))
    Je = Val(Text1(1))
    Bz = Trim(Text1(0))
    With MSFlexGrid1
        .TextMatrix(k, 4) = Trim(Text1(0)) & " "
        .TextMatrix(k, 3) = Format(Val(Text1(1)), "0.00 ")
        .TextMatrix(k, 6) = " " & Rq
         Command3.Enabled = False
    End With
    MyRs3.MoveFirst                                                  ' 修改 T_yf
       Do While Not MyRs3.EOF
          If MyRs3![Bh] = Bhp Then
             MyRs3![Sj] = Sj
             MyRs3![Sl] = Sl
             MyRs3![Je] = Je
             MyRs3![Rq] = Rq
             MyRs3![Bz] = Bz
             MyRs3.Update: Exit Do
          End If
          MyRs3.MoveNext
       Loop
    With MSFlexGrid3
         For i = 1 To N0
             If .TextMatrix(i, 7) Like "*√*" Then
                 MyRs0.MoveFirst                                     ' 修改 T_zm
                 Do While Not MyRs0.EOF
                    If MyRs0![Rq] = arrZm(i, 3) And MyRs0![Xh] = arrZm(i, 0) And MyRs0![Mc] Like "*" & Xmp & "*" Then
                       MyRs0![Bh] = Bh
                       MyRs0.Update: Exit Do
                    End If
                    MyRs0.MoveNext
                 Loop
             End If
         Next
        .Visible = False
    End With
    Call P_init
    strTj = strYf & " And Bh=" & Bhp & " And Mc Like '%" & Xmp & "%'"
    Call P_grd2
End Sub

Private Sub Command4_Click()                                         ' 待报  ??
    strTj = strYd
       Xm = Trim(Combo1.Text)
       If Xm <> "" Then
          strTj = strTj & " And Mc Like '%" & Xm & "%'"
       End If
    Call P_qtxt
    Call P_grd2
    Label4 = "待报销医药费单据："
    Label3 = "备注："
    Command1.Enabled = False
    Command4.Enabled = False
    Command5.Enabled = True
    Command7.Enabled = False
End Sub

Private Sub P_qtxt()
    For i = 0 To 3: Text1(i) = "": Next
    Text1(2) = " " & StrCrq
End Sub

Private Sub Command5_Click()                                         ' 全部
    strTj = strYf
       Xm = Trim(Combo1.Text)
       If Xm <> "" Then
          strTj = strTj & " And Mc Like '%" & Xm & "%'"
       End If
    Call P_qtxt
    Call P_grd2
    Label4 = "全部医药费单据："
    Label3 = "备注："
    MSFlexGrid1.Visible = True
    MSFlexGrid3.Visible = False
    Command4.Enabled = True
    Command5.Enabled = False
    Command7.Enabled = False
End Sub

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

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