frmsztj.frm

这是一个实用的家庭收支管理系统源代码

  Set conn = New ADODB.Connection
  conn.ConnectionString = "DSN=FAM;UDI=admin;PWD=;"
  conn.Open
  conn.Execute sqltxt
  sqltxt = "select * from fxb"
  Set rs = exesql(sqltxt)
  '以下代码处理收入项目
  sqltxt = "select * from income where 级别＝2"
  Set rs1 = exesql(sqltxt)
  If rs1.RecordCount > 0 Then
  rs1.MoveFirst
  rs.AddNew      '添加根节点
  rs.Fields("项目") = Trim(rs1.Fields("父科目"))
  rs.Fields("收或支") = "收入"
  rs.Fields("金额") = 0
  
  Do While Not rs1.EOF
    rs.AddNew       '添加第二层节点
    rs.Fields("项目") = " " + Trim(rs1.Fields("子科目"))
    rs.Fields("收或支") = "收入"
    rs.Fields("金额") = 0
    rs.Update
    sqltxt = "select * from income where 父科目='" + Trim(rs1.Fields("子科目")) + "'"
    Set rs2 = exesql(sqltxt)
    If rs2.RecordCount > 0 Then
       rs2.MoveFirst
       Do While Not rs2.EOF
          rs.AddNew       '添加第三层节点
          rs.Fields("项目") = " " + Trim(rs2.Fields("子科目"))
          rs.Fields("收或支") = "收入"
          rs.Fields("金额") = 0
          rs.Update
          sqltxt = "select * from income where 父科目='" + Trim(rs2.Fields("子科目")) + "'"
          
          Set rs3 = exesql(sqltxt)
          If rs3.RecordCount > 0 Then
          rs3.MoveFirst
          Do While Not rs3.EOF
             rs.AddNew       '添加第四层节点
             rs.Fields("项目") = " " + Trim(rs3.Fields("子科目"))
             rs.Fields("收或支") = "收入"
             rs.Fields("金额") = 0
             rs.Update
             rs3.MoveNext
           Loop
           End If
           rs2.MoveNext
        Loop
      End If
    rs1.MoveNext
  Loop
End If
'以下代码处理支出项目
  sqltxt = "select * from expense where 级别＝2"
  Set rs1 = exesql(sqltxt)
  If rs1.RecordCount > 0 Then
  rs1.MoveFirst
  rs.AddNew      '添加根节点
  rs.Fields("项目") = Trim(rs1.Fields("父科目"))
  rs.Fields("收或支") = "支出"
  rs.Fields("金额") = 0
  
  Do While Not rs1.EOF
    rs.AddNew       '添加第二层节点
    rs.Fields("项目") = " " + Trim(rs1.Fields("子科目"))
    rs.Fields("收或支") = "支出"
    rs.Fields("金额") = 0
    rs.Update
    sqltxt = "select * from expense where 父科目='" + Trim(rs1.Fields("子科目")) + "'"
    Set rs2 = exesql(sqltxt)
    If rs2.RecordCount > 0 Then
       rs2.MoveFirst
       Do While Not rs2.EOF
          rs.AddNew       '添加第三层节点
          rs.Fields("项目") = " " + Trim(rs2.Fields("子科目"))
          rs.Fields("收或支") = "支出"
          rs.Fields("金额") = 0
          rs.Update
          sqltxt = "select * from expense where 父科目='" + Trim(rs2.Fields("子科目")) + "'"
          
          Set rs3 = exesql(sqltxt)
          If rs3.RecordCount > 0 Then
          rs3.MoveFirst
          Do While Not rs3.EOF
             rs.AddNew       '添加第四层节点
             rs.Fields("项目") = " " + Trim(rs3.Fields("子科目"))
             rs.Fields("收或支") = "支出"
             rs.Fields("金额") = 0
             rs.Update
             rs3.MoveNext
           Loop
           End If
           rs2.MoveNext
        Loop
      End If
    rs1.MoveNext
  Loop
End If
    Adodc1.Refresh
    Text1(0).Text = Date
    Text1(1).Text = Date
    
End Sub

Private Sub retCom_Click()
  Unload Me
  
End Sub

Private Sub selcmd1_Click()
  Dim rs As ADODB.Recordset
  Dim rs1 As ADODB.Recordset
  Dim rs2 As ADODB.Recordset
  
  Dim jr As Double
  Dim sqltxt As String
  Dim i As Integer
  Dim condstr As String    '日期条件字符串
  If Trim(Text1(0).Text) <> "" And Not IsDate(Trim(Text1(0).Text)) Then
     MsgBox "起始日期设置不正确", vbOKOnly, "信息提示"
     Text1(0).SetFocus
     Exit Sub
   End If
   If Trim(Text1(1).Text) <> "" And Not IsDate(Trim(Text1(1).Text)) Then
     MsgBox "终止日期设置不正确", vbOKOnly, "信息提示"
     Text1(1).SetFocus
     Exit Sub
   End If
   
   If Trim(Text1(0).Text) > Trim(Text1(1).Text) Then
      MsgBox "日期段设置不正确", vbOKOnly, "信息提示"
      Text1(0).SetFocus
      Exit Sub
    End If
    
    If Trim(Text1(0).Text) <> "" And Trim(Text1(1).Text) <> "" Then
       condstr = "and 日期>='" + Format(Trim(Text1(0).Text), "yyyy.mm.dd") + _
                "'and 日期<='" + Format(Trim(Text1(1).Text), "yyyy.mm.dd") + "'"
    ElseIf Trim(Text1(0).Text) <> "" Then
          condstr = "and 日期>='" + Format(Trim(Text1(0).Text), "yyyy.mm.dd") + "'"
    ElseIf Trim(Text1(1).Text) <> "" Then
          condstr = "and 日期<='" + Format(Trim(Text1(1).Text), "yyyy.mm.dd") + "'"
    Else
          condstr = ""
    End If
    Set conn = New ADODB.Connection     '将收支统计表中各项置0
    conn.ConnectionString = "DSN=FAM;UID=admin;PWD=;"
    conn.Open
    sqltxt = "Update fxb set 金额=0"
    conn.Execute sqltxt
    conn.Close
    '以下代码处理收入项目
    For i = 4 To 2 Step -1
        sqltxt = "select * from income where 级别=" + Trim(Str(i))
        Set rs = exesql(sqltxt)
        If rs.RecordCount > 0 Then
           rs.MoveFirst
           Do While Not rs.EOF
              sqltxt = "select sum(金额) as 金额 from szb where 项目='" + _
              Trim(rs.Fields("子科目")) + "' and 收或支='收入'" + condstr
              Set rs1 = exesql(sqltxt)
                 If Not IsNull(rs1.Fields("金额")) Then
                    '若在明细表szb中存在该收入项目的记录时
                    sqltxt = "select * from fxb where 收或支='收入' and 项目 like '%" + Trim(rs.Fields("子科目")) + "'"
                    Set rs2 = exesql(sqltxt)
                    rs2.Fields("金额") = rs2.Fields("金额") + rs1.Fields("金额")
                    '修改子科目
                    jr = rs2.Fields("金额")
                    rs2.Update
                  Else
                    sqltxt = "select * from fxb where 收或支='收入' and 项目 like '%" + Trim(rs.Fields("子科目")) + "'"
                    Set rs2 = exesql(sqltxt)
                    jr = rs2.Fields("金额")
                    sqltxt = "select * from fxb where 收或支='收入' and 项目 like '%" + Trim(rs.Fields("父科目")) + "'"
                    Set rs2 = exesql(sqltxt)
                    rs2.Fields("金额") = rs2.Fields("金额") + jr
                    '修改父科目
                    rs2.Update
                  End If
                  rs.MoveNext
              Loop
            End If
    Next i
    
    '以下代码处理支出项目
    For i = 4 To 2 Step -1
        sqltxt = "select * from expense where 级别=" + Trim(Str(i))
        Set rs = exesql(sqltxt)
        If rs.RecordCount > 0 Then
           rs.MoveFirst
           Do While Not rs.EOF
              sqltxt = "select sum(金额) as 金额 from szb where 项目='" + _
              Trim(rs.Fields("子科目")) + "' and 收或支='支出'" + condstr
              Set rs1 = exesql(sqltxt)
                 If Not IsNull(rs1.Fields("金额")) Then
                    '若在明细表szb中存在该支出项目的记录时
                    sqltxt = "select * from fxb where 收或支='支出' and 项目 like '%" + Trim(rs.Fields("子科目")) + "'"
                    Set rs2 = exesql(sqltxt)
                    rs2.Fields("金额") = rs2.Fields("金额") + rs1.Fields("金额")
                    '修改子科目
                    jr = rs2.Fields("金额")
                    rs2.Update
                    sqltxt = "select * from fxb where 收或支='支出' and 项目 like '%" + Trim(rs.Fields("父科目")) + "'"
                    Set rs2 = exesql(sqltxt)
                    rs2.Fields("金额") = rs2.Fields("金额") + jr   '修改父科目
                    rs2.Update
                  Else
                    sqltxt = "select * from fxb where 收或支='收入' and 项目 like '%" + Trim(rs.Fields("子科目")) + "'"
                    Set rs2 = exesql(sqltxt)
                    jr = rs2.Fields("金额")
                    sqltxt = "select * from fxb where 收或支='收入' and 项目 like '%" + Trim(rs.Fields("父科目")) + "'"
                    Set rs2 = exesql(sqltxt)
                    rs2.Fields("金额") = rs2.Fields("金额") + jr
                    '修改父科目
                    rs2.Update
                  End If
                  rs.MoveNext
              Loop
            End If
    Next i
    Adodc1.Refresh
End Sub

Private Sub selcmd2_Click()
  Text1(0).Text = ""
  Text1(1).Text = ""
End Sub