📄 frmxb.frm
字号:
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 = "exit"
Unload frmxb
End Select
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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -