frmxb.frm

该软件是一款由VB语言开发的个人财务管理软件

Dim auto As Integer, autm As Integer
Dim ye1 As Integer, ye2 As Integer, mo1 As Byte, mo2 As Byte, da1 As Byte, da2 As Byte
Dim audate As Date

'启动预定系统
Set zbauto = OpenDatabase(App.Path + "\zb.mdb")
Set reauto = zbauto.OpenRecordset("autoadd", dbOpenDynaset)
'Set zbauto = OpenDatabase(App.Path + "\zb.mdb")
Set rexb = zbauto.OpenRecordset("xb", dbOpenDynaset)
If reauto.RecordCount <> 0 Then '若有预定
   reauto.MoveFirst
   Do While reauto.AbsolutePosition <> -1
   '寻找XB中最后一条符合某条预定条件的记录
        rexb.FindLast ("autoadd='" + reauto.Fields(3) + "'" + _
        " and  收支金额=" + Str(reauto.Fields(1)) + _
        " and  类别='" + reauto.Fields(2) + "'")
          If Not (rexb.NoMatch) Then '若XB中有这样一条由预定产生的记录
             audate = rexb.Fields(0)
             auto = Date - rexb.Fields(0) '今天距那天有多少天间隔
             ye1 = Val(Mid(Format(Date, "yyyy-mm-dd"), 1, 4)): ye2 = Val(Mid(Format(rexb.Fields(0), "yyyy-mm-dd"), 1, 4))
             mo1 = Month(Date): mo2 = Month(rexb.Fields(0))
             da1 = Val(Mid(Format(Date, "yy-mm-dd"), 7, 2))
             da2 = Val(Mid(Format(rexb.Fields(0), "yy-mm-dd"), 7, 2))
             autm = (ye1 - ye2) * 12 + (mo1 - mo2)
             If da1 < da2 Then
                autm = autm - 1
             End If
             
          Select Case rexb.Fields(5)
               Case "每天"
               For i = 1 To auto
                   rexb.AddNew
                   rexb.Fields(0) = DateAdd("D", i, audate) 'Date - (i - 1) * 1
                   rexb.Fields(1) = reauto.Fields(1)
                   rexb.Fields(2) = reauto.Fields(2)
                   rexb.Fields(5) = reauto.Fields(3)
                   rexb.Fields(3) = reauto.Fields(4)
                   If Mid(rexb.Fields(2), 4, 1) = "入" Then
                        rexb.Fields(4) = True
                   Else
                         rexb.Fields(4) = False
                   End If
                   rexb.Update
               Next i
               Case "每周"
                For i = 1 To Int(auto / 7)
                   rexb.AddNew
                   rexb.Fields(0) = DateAdd("ww", i, audate)
                   rexb.Fields(1) = reauto.Fields(1)
                   rexb.Fields(2) = reauto.Fields(2)
                   rexb.Fields(5) = reauto.Fields(3)
                   rexb.Fields(3) = reauto.Fields(4)
                   If Mid(rexb.Fields(2), 4, 1) = "入" Then
                        rexb.Fields(4) = True
                   Else
                         rexb.Fields(4) = False
                   End If
                   rexb.Update
               Next i
               Case "每月"
                For i = 1 To autm
                   rexb.AddNew
                   rexb.Fields(0) = DateAdd("m", i, audate)
                   rexb.Fields(1) = reauto.Fields(1)
                   rexb.Fields(2) = reauto.Fields(2)
                   rexb.Fields(5) = reauto.Fields(3)
                   rexb.Fields(3) = reauto.Fields(4)
                   If Mid(rexb.Fields(2), 4, 1) = "入" Then
                        rexb.Fields(4) = True
                   Else
                         rexb.Fields(4) = False
                   End If
                   rexb.Update
               Next i
               Case "每季"
                For i = 1 To Int(autm / 3)
                   rexb.AddNew
                   rexb.Fields(0) = DateAdd("m", i * 3, audate)
                   rexb.Fields(1) = reauto.Fields(1)
                   rexb.Fields(2) = reauto.Fields(2)
                   rexb.Fields(5) = reauto.Fields(3)
                   rexb.Fields(3) = reauto.Fields(4)
                   If Mid(rexb.Fields(2), 4, 1) = "入" Then
                        rexb.Fields(4) = True
                   Else
                         rexb.Fields(4) = False
                   End If
                   rexb.Update
               Next i
               Case "每年"
                For i = 1 To Int(autm / 12)
                   rexb.AddNew
                   rexb.Fields(0) = DateAdd("yyyy", i, audate)
                   rexb.Fields(1) = reauto.Fields(1)
                   rexb.Fields(2) = reauto.Fields(2)
                   rexb.Fields(5) = reauto.Fields(3)
                   rexb.Fields(3) = reauto.Fields(4)
                   If Mid(rexb.Fields(2), 4, 1) = "入" Then
                        rexb.Fields(4) = True
                   Else
                         rexb.Fields(4) = False
                   End If
                   rexb.Update
               Next i
         End Select
          Else '若XB中没有这样一条由预定产生的记录,也就是有条预定还没有起作用
             audate = reauto.Fields(0)
             auto = Date - reauto.Fields(0)  '今天距那天有多少天间隔
             ye1 = Val(Mid(Format(Date, "yyyy-mm-dd"), 1, 4)): ye2 = Val(Mid(Format(reauto.Fields(0), "yyyy-mm-dd"), 1, 4))
             mo1 = Month(Date): mo2 = Month(reauto.Fields(0))
             da1 = Val(Mid(Format(Date, "yy-mm-dd"), 7, 2))
             da2 = Val(Mid(Format(reauto.Fields(0), "yy-mm-dd"), 7, 2))
             autm = (ye1 - ye2) * 12 + mo1 - mo2
             If da1 < da2 Then
                autm = autm - 1
             End If
              If auto > 0 Then '已过了预定的日期
               rexb.AddNew     '则增加一个预定记录
                   rexb.Fields(0) = reauto.Fields(0)
                   rexb.Fields(1) = reauto.Fields(1)
                   rexb.Fields(2) = reauto.Fields(2)
                   rexb.Fields(5) = reauto.Fields(3)
                   rexb.Fields(3) = reauto.Fields(4)
                   If Mid(rexb.Fields(2), 4, 1) = "入" Then
                        rexb.Fields(4) = True
                   Else
                         rexb.Fields(4) = False
                   End If
                   rexb.Update
              End If
             Select Case reauto.Fields(3)
               Case "每天"
               For i = 1 To auto
                   rexb.AddNew
                   rexb.Fields(0) = DateAdd("d", i, audate)
                   rexb.Fields(1) = reauto.Fields(1)
                   rexb.Fields(2) = reauto.Fields(2)
                   rexb.Fields(5) = reauto.Fields(3)
                   rexb.Fields(3) = reauto.Fields(4)
                   If Mid(rexb.Fields(2), 4, 1) = "入" Then
                        rexb.Fields(4) = True
                   Else
                         rexb.Fields(4) = False
                   End If
                   rexb.Update
               Next i
               Case "每周"
                For i = 1 To Int(auto / 7)
                   rexb.AddNew
                   rexb.Fields(0) = DateAdd("ww", i, audate)
                   rexb.Fields(1) = reauto.Fields(1)
                   rexb.Fields(2) = reauto.Fields(2)
                   rexb.Fields(5) = reauto.Fields(3)
                   rexb.Fields(3) = reauto.Fields(4)
                   If Mid(rexb.Fields(2), 4, 1) = "入" Then
                        rexb.Fields(4) = True
                   Else
                         rexb.Fields(4) = False
                   End If
                   rexb.Update
               Next i
               Case "每月"
                For i = 1 To autm
                   rexb.AddNew
                   rexb.Fields(0) = DateAdd("m", i, audate)
                   rexb.Fields(1) = reauto.Fields(1)
                   rexb.Fields(2) = reauto.Fields(2)
                   rexb.Fields(5) = reauto.Fields(3)
                   rexb.Fields(3) = reauto.Fields(4)
                   If Mid(rexb.Fields(2), 4, 1) = "入" Then
                        rexb.Fields(4) = True
                   Else
                         rexb.Fields(4) = False
                   End If
                   rexb.Update
               Next i
               Case "每季"
                For i = 1 To Int(autm / 3)
                   rexb.AddNew
                   rexb.Fields(0) = DateAdd("m", i * 3, audate)
                   rexb.Fields(1) = reauto.Fields(1)
                   rexb.Fields(2) = reauto.Fields(2)
                   rexb.Fields(5) = reauto.Fields(3)
                   rexb.Fields(3) = reauto.Fields(4)
                   If Mid(rexb.Fields(2), 4, 1) = "入" Then
                        rexb.Fields(4) = True
                   Else
                         rexb.Fields(4) = False
                   End If
                   rexb.Update
               Next i
               Case "每年"
                For i = 1 To Int(autm / 12)
                   rexb.AddNew
                   rexb.Fields(0) = DateAdd("yyyy", i, audate)
                   rexb.Fields(1) = reauto.Fields(1)
                   rexb.Fields(2) = reauto.Fields(2)
                   rexb.Fields(5) = reauto.Fields(3)
                   rexb.Fields(3) = reauto.Fields(4)
                   If Mid(rexb.Fields(2), 4, 1) = "入" Then
                        rexb.Fields(4) = True
                   Else
                         rexb.Fields(4) = False
                   End If
                   rexb.Update
               Next i
         End Select
    End If
    reauto.MoveNext
    Loop
End If

Dim reyear As Recordset
Set reyear = zbauto.OpenRecordset("year")

If rexb.RecordCount = 0 Then '没有任何记录，则是第一次使用
Set reauto = zbauto.OpenRecordset("yzj", dbOpenDynaset)
    frmfirst.Show 1
                         If frmfirst.firdate = "" Then
                        MsgBox "您什么都没有输入,下次在用吧。B-b!", 48, "再见"
                         Call Form_Unload(0)
                         End
                        End If
 
                         If reyear.RecordCount = 0 Then
                        reyear.AddNew
                        reyear.Fields(0) = Mid(Format(CDate(frmfirst.firdate), "yyyy-mm-dd"), 1, 4) '保证在YEAR表中有一个年度
                        reyear.Update
                        
                          End If
rexb.AddNew
   rexb.Fields(0) = CDate(frmfirst.firdate)
   rexb.Fields(1) = 0
   rexb.Fields(2) = "其它收入"
   rexb.Fields(3) = "这是程序自己加的记录,你可以修改它."
   rexb.Fields(4) = True
   rexb.Update
   myyear = Mid(Format(CDate(frmfirst.firdate), "yyyy-mm-dd"), 1, 4)
rexb.Close

    Dim reyzj As Recordset
    Set reyzj = zbauto.OpenRecordset("yzj")
    reyzj.AddNew
    reyzj.Fields(0) = CDate(frmfirst.firdate)
    reyzj.Fields(1) = frmfirst.firmoney
    reyzj.Update
    reyzj.Close
   reauto.Close
End If

   reyear.MoveLast
myyear = reyear.Fields(0)
Me.Caption = "小小收支薄-每日收支详情登记" + "(" + myyear + "年度)"
Data1.DatabaseName = App.Path + "\zb.mdb"
Data1.RecordSource = "select * from xb where year(收支日期)='" + myyear + "' order by 收支日期"
Data1.Refresh
Data2.DatabaseName = App.Path + "\zb.mdb"
Data2.RecordSource = "select * from yzj where year(年月)='" + myyear + "' order by 年月"
Data2.Refresh


Dim n As Integer

Data1.Recordset.MoveFirst
Do

Data1.Recordset.MoveNext
Loop Until Data1.Recordset.AbsolutePosition = -1 'Data1.Recordset.RecordCount - 1   '是否到最后一个记录(不是检测记录末)
If Data1.Recordset.RecordCount = 1 Then Toolbar1.Buttons.Item(4).Enabled = False '若此句放在前面recordcount为1,经movefirst记录移动后,得到recordcount正确值.
Data1.Recordset.MoveFirst
'设置标尺属性
If Data1.Recordset.RecordCount > 1 Then
Slirecon.max = Data1.Recordset.RecordCount - 1
Slirecon.LargeChange = Int(Slirecon.max / 10) + 1
Else
Slirecon.max = Data1.Recordset.RecordCount
Slirecon.LargeChange = 0
End If
Label9.Caption = Str(Data1.Recordset.RecordCount)
Label10.Caption = Str(Data1.Recordset.AbsolutePosition + 1)
Dim t As Boolean
t = True
visok (t)
mok
End Sub



Private Sub Form_Unload(Cancel As Integer)
Dim i As Integer, j As Integer
j = Forms.Count - 1
For i = 0 To j
Unload Forms(0)
Next i
End Sub

Private Sub HELP_Click()

'MYHELP
End Sub


Private Sub JS_Click()
dctable ("yzj")
End Sub

Private Sub PX_Click()
Command5_Click
End Sub

Private Sub SC_Click()
Command2_Click
End Sub

Private Sub Slirecon_Change()
'Debug.Print Slirecon.Value
Data1.Recordset.MoveFirst
Data1.Recordset.Move Slirecon.Value
mok
End Sub

Private Sub sy_Click()
Command4_Click
End Sub

Private Sub SZ_Click()
dctable ("xb")
End Sub

Private Sub Text1_LostFocus(Index As Integer)
If Not IsDate(Text1(0).Text) Then
Text1(0).SetFocus
Text1(0).SelStart = 0
Text1(0).SelLength = Len(Text1(0).Text)
End If
If Not IsNumeric(Text1(1).Text) Then
Text1(1).SetFocus
Text1(1).SelStart = 0
Text1(1).SelLength = Len(Text1(0).Text)
End If
End Sub

Private Sub textfind_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Call textfind_LostFocus
End If
End Sub

Private Sub textfind_LostFocus()
If Not IsDate(textfind.Text) Then
With textfind
.SelStart = 0
.SelLength = Len(.Text)
.SetFocus
End With
Else
Data1.Recordset.FindFirst "收支日期=CDate('" + textfind.Text + "')"
            If Data1.Recordset.NoMatch Then
MsgBox "没有找到" + textfind.Text + "的收支情况！" + Chr(13) + Chr(13) + "将查找最接近的一个收支个记录。", 48, "查找"

Data1.Recordset.FindLast "收支日期<=CDate('" + textfind.Text + "')"
            End If
End If
 Call mok
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As ComctlLib.Button)
Select Case Button.Key
       Case Is = "add"
       Command1_Click
       Case Is = "pre"
        Command4_Click
       Case Is = "next"
        Command3_Click
       Case Is = "edit"
       comedit_Click
       Case Is = "ok"
       Comok_Click
       Case Is = "cancel"
       Comcancl_Click
       Case Is = "del"
       Command2_Click
       Case Is = "js"
       Comzt_Click
       Case Is = "index"
       Command5_Click
       Case Is = "find"
       comlr_Click
       Case Is = "ctrl"
       Comauto_Click
       Case Is = "table"
       comtable_Click
       Case Is = "help"
       MYHELP
       'MsgBox "帮助尚未建立！", 48, "sorry"
       Case Is = "about"
       Frmabout.Show 1
       Case Is = "exit"
      Unload frmxb
End Select
End Sub

Private Sub WRITER_Click()
 Frmabout.Show 1
End Sub

Private Sub xg_Click()
comedit_Click
End Sub

Private Sub XY_Click()
Command3_Click
End Sub

Private Sub xz_Click()
frmyear.Show 1
End Sub

Private Sub YD_Click()
Comauto_Click
End Sub

Private Sub YJS_Click()
Comzt_Click
End Sub

Private Sub zj_Click()
Command1_Click
End Sub