frmxb.frm

个人财务计算的好工具

   n = MsgBox("未到12月31日,如提前作年终处理,则使统计数据不准和这以后的数据当年度查不到!(除非在元旦前不输数据)" + Chr(13) + "你的确要作此处理吗?", 36, "年终处理")
   If n = 7 Then Exit Sub
End If

Comzt_Click '整年处理
Dim i As Integer, j As Integer, SZ As Single
Dim zb As Database
Dim reyear As Recordset
Dim reyzj As Recordset
Set zb = OpenDatabase(App.Path + "\zb.mdb")
Set reyear = zb.OpenRecordset("year", dbOpenDynaset) 'dbOpenDynaset类型才能用find
reyear.FindFirst ("年度='" + myyear + "'") '在YEAR表中找当前年度的处理情况
If reyear.NoMatch = True Then '若没有当前年度的记录则加入
reyear.AddNew
reyear.Fields(0) = myyear
reyear.Update
reyear.FindFirst ("年度='" + myyear + "'")
End If
Data2.Recordset.MoveLast
Data2.Recordset.MoveFirst 'YZJ表移到头
reyear.Edit
If reyear.AbsolutePosition = 0 Then '如果是年度中的第一个记录
   reyear.Fields(1) = Data2.Recordset.Fields(1) '则用月表中的第一条记录的上月结余
Else                                            '若是其它年度记录则用上年度的结余
   reyear.MovePrevious
   SZ = reyear.Fields(4)
   reyear.MoveNext
   reyear.Edit
   reyear.Fields(1) = SZ
End If
For i = 5 To reyear.Fields.Count - 1
    SZ = 0
    For j = 1 To Data2.Recordset.RecordCount
      SZ = Data2.Recordset.Fields(i) + SZ '循环计算YZJ表中各项收支数值和并存入YEAR表中
      Data2.Recordset.MoveNext
    Next j
    reyear.Fields(i) = SZ
    Data2.Recordset.MoveFirst
Next i
Data2.Recordset.MoveLast
reyear.Fields(2) = 0
reyear.Fields(3) = 0
For i = 1 To 5
reyear.Fields(2) = reyear.Fields(i + 4) + reyear.Fields(2) '当年的收入
reyear.Fields(3) = reyear.Fields(i + 9) + reyear.Fields(3) '当年的支出
Next i
reyear.Fields(4) = reyear.Fields(1) + reyear.Fields(2) - reyear.Fields(3) '得到当年结余
SZ = reyear.Fields(4)
reyear.Update
reyear.FindFirst ("年度 ='" + Trim(Str(Val(myyear) + 1)) + "'") '当年处理完后,找下一年度的记录
If reyear.NoMatch = True Then
reyear.AddNew '没有则加入
Else
reyear.Edit
End If
reyear.Fields(0) = Trim(Str(Val(myyear) + 1)) '并且对year表中下一年度初始化
reyear.Fields(1) = SZ
reyear.Update
Set reyzj = zb.OpenRecordset("yzj", dbOpenDynaset) '打开含有每年收支数据的YZJ表(dbOpenDynaset类型才能用find)
reyzj.FindFirst ("year(年月)='" + Trim(Str(Val(myyear) + 1)) + "'") '查找下一年度的第一条记录
If reyzj.NoMatch = True Then
reyzj.AddNew '没找到则加入
reyzj.Fields(0) = CDate(Trim(Str(Val(myyear) + 1)) + "-1-1") '时间定为一月
Else
reyzj.Edit '有则修改
End If
reyzj.Fields(1) = SZ 'YZJ表中的上月结余修改
reyzj.Update

Set reyzj = zb.OpenRecordset("xb", dbOpenDynaset) '打开含有每天收支数据的XB表(dbOpenDynaset类型才能用find)
reyzj.FindFirst ("year(收支日期)='" + Trim(Str(Val(myyear) + 1)) + "'") '查找下一年度的第一条记录
If reyzj.NoMatch = True Then
reyzj.AddNew '没找到则加入
reyzj.Fields(0) = CDate(Trim(Str(Val(myyear) + 1)) + "-1-1") '时间定为一月
reyzj.Fields(1) = 0
reyzj.Fields(2) = "其它收入"
reyzj.Fields(3) = "这条记录是程序自己加的,若本年中没有其它收支记录,请不要删除它,但可以修改."
reyzj.Fields(4) = False
reyzj.Update '加入一个0收入的记录使程序下次启动时不会测到最新年度记录数为0
End If
reyzj.Close
reyear.FindFirst ("年度 ='" + myyear + "'") '回到刚处理的年度
MsgBox myyear + "年度情况：" + Chr(13) + "去年结余：" + Str(reyear.Fields(1)) + Chr(13) _
+ "当年收入：" + Str(reyear.Fields(2)) + Chr(13) + "当年支出：" + Str(reyear.Fields(3)) + Chr(13) _
+ "当年结余：" + Str(reyear.Fields(4)) + Chr(13), 48, myyear + "年度处理完毕"

End Sub

Private Sub Comauto_Click()
Frmadd.Show 1
Data2.Refresh
End Sub

Private Sub Combo1_LostFocus()
Select Case Combo1.Text
 Case "工资收入"
 Case "奖金收入"
 Case "福利收入"
 Case "打工收入"
 Case "其它收入"
 Case "生活支出"
 Case "娱乐支出"
 Case "学习支出"
 Case "投资支出"
 Case "其它支出"
 Case Else
 MsgBox "您输入的收支类别不合程序要求，这可能会造成计算及查询的不正确！" + Chr(13) + "请点击右边的下拉箭头，并从中选择一个类别！", 48, "类别错误"
 Combo1.SelStart = 0
 Combo1.SelLength = Len(Combo1.Text)
 Combo1.SetFocus
 End Select
 
End Sub

Private Sub Comcancl_Click()
On Error Resume Next

Data1.Recordset.CancelUpdate


Dim t As Boolean
t = True
visok (t)
Call mok
End Sub

Private Sub comedit_Click()

Dim t As Boolean
t = False
visok (t)
Data1.Recordset.Edit
End Sub

Private Sub comlr_Click()
Frmlr.Show 1
End Sub




Private Sub comtable_Click()
Frmpic.Show 1
End Sub

Private Sub Comok_Click()
On Error Resume Next
Data1.Recordset.Update
Dim t As Boolean
t = True
visok (t)
Call mok
End Sub

Private Sub Comzt_Click()
Dim sl(4) As Single, zc(4) As Single 'sl(收入数组)zc(支出数组)
Dim zsl As Single, zzc As Single '总收入\支出
Data1.Refresh '记录刷新(重新排序)
Data1.Recordset.MoveLast
Data1.Recordset.MoveFirst
Dim i As Integer, j As Integer
Dim qmdate As Date, qmju As Single '前面日期和结余
For j = 1 To 12
    For i = 0 To 4
    sl(i) = 0
    zc(i) = 0
    Next i
    zsl = 0
    zzc = 0
    Data1.Recordset.FindFirst "month(收支日期)=" + Str(j) '查找i月份
        If Month(Data1.Recordset.Fields(0)) <> j Then '如没有
        GoTo last
    End If
Do While Data1.Recordset.AbsolutePosition <> -1 '是否到尾(不是最后一个记录)
        If Month(Data1.Recordset.Fields(0)) = j Then
          Select Case Data1.Recordset.Fields(2) '分类计算
                 Case "工资收入"
                sl(0) = Data1.Recordset.Fields(1) + sl(0)
                 Case "奖金收入"
                sl(1) = Data1.Recordset.Fields(1) + sl(1)
                 Case "福利收入"
                sl(2) = Data1.Recordset.Fields(1) + sl(2)
                 Case "打工收入"
                sl(3) = Data1.Recordset.Fields(1) + sl(3)
                 Case "其它收入"
                sl(4) = Data1.Recordset.Fields(1) + sl(4)
                 Case "生活支出"
                zc(0) = Data1.Recordset.Fields(1) + zc(0)
                 Case "娱乐支出"
                zc(1) = Data1.Recordset.Fields(1) + zc(1)
                 Case "学习支出"
                zc(2) = Data1.Recordset.Fields(1) + zc(2)
                 Case "投资支出"
                zc(3) = Data1.Recordset.Fields(1) + zc(3)
                 Case "其它支出"
                zc(4) = Data1.Recordset.Fields(1) + zc(4)
          End Select
           Data1.Recordset.MoveNext '测试下一个记录是否合适条件
        Else
           Exit Do
        End If
 Loop
 Data1.Refresh

For i = 0 To 4
zsl = zsl + sl(i) '总收入
zzc = zzc + zc(i) '总支出
Next i
    Data2.Recordset.FindFirst "month(年月)=" + Str(j) '查找统计表中的j月记录
    
If Month(Data2.Recordset.Fields(0)) <> j Then '没有
          Data2.Recordset.FindFirst "month(年月)=" + Str(j - 1) '查找统计表中的上一月记录
          qmdate = Data2.Recordset.Fields(0)
          qmju = Data2.Recordset.Fields(4)
          Data2.Recordset.AddNew
          Data2.Recordset.Fields(0) = qmdate + 32
   '       Data2.Recordset.Fields(0) = CDate(Str(year(CDate(qmdate))) + "-" + Trim(Str(HScroll1.Value)) + "-1")
          Data2.Recordset.Fields(1) = qmju
          Data2.Recordset.Update
End If
   Data2.Recordset.FindFirst "month(年月)=" + Str(j - 1) '查找统计表中的上一月记录
   If Data2.Recordset.NoMatch Then '本月就是第一条，找不到上月的
     qmju = Data2.Recordset.Fields(1)
   Else
     qmju = Data2.Recordset.Fields(4)
   End If
   Data2.Recordset.FindFirst "month(年月)=" + Str(j) '查找统计表中的当月记录
   Data2.Recordset.Edit
   Data2.Recordset.Fields(1) = qmju
   Data2.Recordset.Fields(2) = zsl
   Data2.Recordset.Fields(3) = zzc
   Data2.Recordset.Fields(4) = Data2.Recordset.Fields(1) + zsl - zzc
For i = 0 To 4
Data2.Recordset.Fields(i + 5) = sl(i)
Data2.Recordset.Fields(i + 10) = zc(i)
Next i
Data2.Recordset.Update
last:
Next j
visok (True)
mok

End Sub

Private Sub CX_Click()
comlr_Click
End Sub

Private Sub Data1_Error(DataErr As Integer, Response As Integer)
  '这就是放置错误处理代码的地方
  '如果想忽略错误，注释掉下面的行
  '如果想捕捉错误，在这里添加错误处理代码
  MsgBox "数据错误事件捕捉到错误：" & Error$(DataErr)
  Response = 0  '忽略错误
End Sub



Private Sub Command1_Click()

Data1.Recordset.AddNew
Data1.Recordset(2) = "工资收入"
Data1.Recordset.Update
Data1.Recordset.MoveLast
Dim t As Boolean
t = False
visok (t)
Data1.Recordset.Edit
Slirecon.max = Data1.Recordset.RecordCount - 1
Slirecon.LargeChange = Int(Slirecon.max / 10) + 1
Label9.Caption = Data1.Recordset.RecordCount
End Sub

Private Sub Command2_Click()
On Error Resume Next
If Data1.Recordset.RecordCount = 1 Then
Dim zb As Database
Dim reyear As Recordset
Dim i As Integer, n As Integer
'Data1.Recordset.Delete
MsgBox "你删除本年最后一条收支情况，程序将关闭!", 48, "下次再来吧!"
Set zb = OpenDatabase(App.Path + "\zb.mdb")
Set reyear = zb.OpenRecordset("year", dbOpenDynaset)
n = reyear.RecordCount
For i = 1 To n + 1
    reyear.Delete
    reyear.MoveFirst
Next i
Set reyear = zb.OpenRecordset("yzj", dbOpenDynaset)
n = reyear.RecordCount
For i = 1 To n + 1
    reyear.Delete
    reyear.MoveFirst
Next i
Set reyear = zb.OpenRecordset("autoadd", dbOpenDynaset)
n = reyear.RecordCount
For i = 1 To n + 1
    reyear.Delete
    reyear.MoveFirst
Next i
Set reyear = zb.OpenRecordset("xb", dbOpenDynaset)
n = reyear.RecordCount
For i = 1 To n + 1
    reyear.Delete
    reyear.MoveFirst
Next i

Form_Unload (0)
Exit Sub
End If
        Dim ko As Integer, strsj As String, book As Variant
        strsj = Data1.Recordset.Fields(0) & " " & Str(Data1.Recordset.Fields(1)) & "元" & Data1.Recordset.Fields(3) & "的情况吗?"
        ko = MsgBox("的确要删除" + strsj, 36, "删除记录")
        If ko = vbYes Then
      
          ko = Data1.Recordset.AbsolutePosition
                   
             Data1.Recordset.Delete '每作一次删除，AbsolutePosition =-1,当前无记录
                Data1.Refresh '记录刷新(重新排序)
                Data1.Recordset.MoveFirst
                Data1.Recordset.MoveLast
                Data1.Recordset.MoveFirst
                    If ko < Data1.Recordset.RecordCount - 1 Then
                Data1.Recordset.Move ko
                    Else
                Data1.Recordset.Move ko - 1
                    End If
              
        End If
 Call mok

Slirecon.max = Data1.Recordset.RecordCount - 1
Slirecon.LargeChange = Int(Slirecon.max / 10) + 1
Label9.Caption = Data1.Recordset.RecordCount
End Sub

Private Sub Command3_Click()
'Command4.Enabled = True '上移按钮有效
Toolbar1.Buttons.Item(3).Enabled = True
sy.Enabled = True
Data1.Recordset.MoveNext '下移
If Data1.Recordset.AbsolutePosition = Data1.Recordset.RecordCount - 1 Or Data1.Recordset.AbsolutePosition = -1 Then '是否到最后一个记录(不是检测记录末)
'Command3.Enabled = False '如是则下移按钮失效
Toolbar1.Buttons.Item(4).Enabled = False
XY.Enabled = False
End If
textfind.Text = Format(Data1.Recordset.Fields(0), "yyyy-mm-dd")
Slirecon.Value = Data1.Recordset.AbsolutePosition
Label10.Caption = Str(Data1.Recordset.AbsolutePosition + 1)
End Sub

Private Sub Command4_Click()
'Command3.Enabled = True
Toolbar1.Buttons.Item(4).Enabled = True
XY.Enabled = True
Data1.Recordset.MovePrevious
If Data1.Recordset.AbsolutePosition = 0 Or Data1.Recordset.AbsolutePosition = -1 Then '是否到第一个记录(不是检测记录头)
'Command4.Enabled = False
Toolbar1.Buttons.Item(3).Enabled = False
sy.Enabled = False
End If
textfind.Text = Format(Data1.Recordset.Fields(0), "yyyy-mm-dd")
Slirecon.Value = Data1.Recordset.AbsolutePosition
Label10.Caption = Str(Data1.Recordset.AbsolutePosition + 1)
End Sub




Private Sub Command5_Click()
Data1.Refresh '记录刷新(重新排序)
Data1.Recordset.MoveFirst
Data1.Recordset.MoveLast
Data1.Recordset.MoveFirst
mok
Slirecon.max = Data1.Recordset.RecordCount - 1
Slirecon.LargeChange = Int(Slirecon.max / 10) + 1
End Sub





'Private Sub Data2_Reposition()
''HScroll1.Value = Month(Data2.Recordset.Fields(0))
'Command6.Caption = "计算" & Trim(Str(HScroll1.Value)) & "月份"
'End Sub

Private Sub EX_Click()
comtable_Click
End Sub

Private Sub EXIT_Click()
Unload frmxb
End Sub

Private Sub Form_Activate()
Me.Caption = "小小收支薄-每日收支详情登记" + "(" + myyear + "年度)"
Data1.RecordSource = "select * from xb where year(收支日期)='" + myyear + "' order by 收支日期"
Data1.Refresh
Data2.RecordSource = "select * from yzj where year(年月)='" + myyear + "' order by 年月"
Data2.Refresh
Data1.Recordset.MoveFirst
'Data2.Recordset.MoveFirst
visok (True)
mok

End Sub

Private Sub Form_Load()
Dim i As Integer
Combo1.AddItem "工资收入"
Combo1.AddItem "奖金收入"
Combo1.AddItem "福利收入"
Combo1.AddItem "打工收入"
Combo1.AddItem "其它收入"
Combo1.AddItem "生活支出"
Combo1.AddItem "学习支出"
Combo1.AddItem "娱乐支出"
Combo1.AddItem "投资支出"
Combo1.AddItem "其它支出"

Dim zbauto As Database
'Dim zb As Database
Dim rexb As Recordset
Dim reauto As Recordset
Dim autodate As Date
Dim auto As Integer, autm As Integer