📄 forma0.frm
字号:
If F_jcsr Then Command1.Enabled = True
End If
With MSFlexGrid1
Select Case Index
Case 1
StrMsg = Trim(Text1(1))
Label9 = Left(Trim(Text1(1)), 7)
.TextMatrix(intRo1, 1) = " " & Right(StrMsg, 2)
Case 3
.TextMatrix(intRo1, 2) = " " & Trim(Text1(3))
Case 4
Call P_jsje: .TextMatrix(intRo1, 3) = Format(Val(Text1(4)), "0.00 ")
Case 5
If Trim(Text1(5)) = "" Then
Text1(6) = Text1(4)
Text1(4) = ""
End If
.TextMatrix(intRo1, 4) = Format(Val(Text1(5)), "0.00 ")
If F_jcsr Then Command1.Enabled = True
Case 6
If Sz = "s" Then
.TextMatrix(intRo1, 5) = Format(Val(Text1(6)), "0.00 ")
.TextMatrix(intRo1, 6) = ""
Else
.TextMatrix(intRo1, 5) = ""
.TextMatrix(intRo1, 6) = Format(Val(Text1(6)), "0.00 ")
End If
'.TextMatrix(intRo1, 7) = Format(Val(Text1(6)), "0.00 ") ' ???
If F_jcsr Then Command1.Enabled = True
Case 7
.TextMatrix(intRo1, 8) = " " & Trim(Text1(7))
End Select
End With
End If
End Sub
Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii <> 13 Then Exit Sub
Select Case Index
Case 4
If Text1(4) = "" Then
Text1(5) = ""
Text1(6).Enabled = True: Text1(6).SetFocus
Else
Text1(5).SetFocus
End If
Case 5
If Text1(5) = "" Then
Text1(6) = Text1(4)
Text1(4) = ""
End If
Text1(6).SetFocus
Case 7
If F_jcsr Then Command1.SetFocus
Case Else
Text1(Index + 1).SetFocus
End Select
End Sub
Private Sub Text1_LostFocus(Index As Integer)
If blnSp Or Trim(Text1(Index)) = "" Then Exit Sub
Select Case Index
Case 1 ' 日期格式规格化
Rqs = Trim(Text1(1))
Text1(1) = " " & mF_rqgs(Rqs)
' Text1(1) = " " & myF_ctos(Text1(1))
If Text1(1) Like "*F*" Then
Text1(1) = "": Text1(1).SetFocus
End If
Case 1, 3, 7
Text1(Index) = " " & Trim(Text1(Index))
Case 4, 5
If Text1(Index) <> "" Then
Call P_jsje
Text1(Index) = " " & IIf(Index = 4, Format(Val(Text1(4)), "0.00"), Trim(Text1(5)))
End If
Case 4, 6
If Index = 4 Then Call P_jsje
Text1(Index) = Format(Val(Text1(Index)), " 0.00")
End Select
End Sub
Private Sub P_jsje()
Text1(6) = Format(Val(Text1(4)) * Val(Text1(5)), " 0.00")
End Sub
Function F_jcsr() As Boolean ' 检查输入的完整性
F_jcsr = True
For i = 1 To 6
If i = 4 Or i = 5 Then Exit For
If Trim(Text1(i)) = "" Then
Text1(i).SetFocus
Command1.Enabled = False
F_jcsr = False: Exit For
End If
Command1.Enabled = True
Next
End Function
Private Sub MSFlexGrid1_KeyPress(KeyAscii As Integer) ' 选中一笔帐目
If KeyAscii = 13 Then Call MSFlexGrid1_Click
End Sub
Private Sub MSFlexGrid1_Click() ' 选中一笔
With MSFlexGrid1
If Trim(.TextMatrix(.Row, 7)) = "" Then Exit Sub
k = .Row
strFs = "2"
blnSp = True
Call P_setb
Frame1.Visible = True
Command5.Visible = False
Command6.Visible = False
intRos = 20
Label9 = Left(StrCrq, 7)
.Top = 3120
.Height = 225 * IIf(intTs > intRos, 21, intTs + 2) + 90
.Col = 8: .ColWidth(8) = 2100 - IIf(.Rows > intRos, 270, 0)
Label9.Top = .Top - 240
.Row = k
For j = 1 To .Cols - 1
.Col = j: .CellBackColor = intCx1 ' 设置颜色
Next
.Row = intRo1
For j = 1 To .Cols - 1
.Col = j: .CellBackColor = intCy1 ' 颜色复原
Next
intRo1 = k
.Row = k
Command2.Enabled = True
Command3.Enabled = True
Xhp = arrZm(k, 0) ' 序号 Xhp
Szp = arrZm(k, 1)
Option1(0).Value = IIf(Szp = "s", True, False)
Call P_cmb1
Yep = arrZm(k, 3) ' ?
Rqp = Label9 & "." & Trim(.TextMatrix(k, 1))
Text1(1) = " " & Rqp
Lbp = arrZm(k, 2): Text1(2) = Lbp
Mcp = Trim(.TextMatrix(k, 2)): Text1(3) = " " & Mcp
Djp = Val(.TextMatrix(k, 3)): Text1(4) = IIf(Djp = 0, "", Format(Djp, " 0.00"))
Slp = Val(.TextMatrix(k, 4)): Text1(5) = IIf(Slp = 0, "", Format(Slp, " 0.00"))
Jep = Val(IIf(Sz = "s", .TextMatrix(k, 5), .TextMatrix(k, 6)))
Text1(6) = Format(Jep, " 0.00")
Bzp = Trim(.TextMatrix(k, 8)): Text1(7) = " " & Bzp
End With
Call P_setb
If Mcp Like "*医药费报销*" Then blnBx = True
Text1(3).SetFocus
blnSp = False
End Sub
Private Sub P_setb()
For i = 1 To 7: Text1(i).Enabled = True: Next
Option1(0).Enabled = True
Option1(1).Enabled = True
Combo1.Enabled = True
With MSFlexGrid1
.Row = .Rows - 1: .Col = 2: .Text = Combo1.Text
End With
Sz = IIf(Option1(0), "s", "z")
End Sub
Private Sub Command1_Click() ' 存盘
If Val(Text1(6)) = 0 Then
Text1(6).SetFocus: Command1.Enabled = False: Exit Sub
End If
Rq = Trim(Text1(1))
Lb = Trim(Text1(2))
Mc = Trim(Text1(3))
Sz = IIf(Option1(0), "s", "z")
Dj = Val(Text1(4))
Sl = Val(Text1(5))
Je = Val(Text1(6))
Sr = IIf(Sz = "s", Val(Text1(6)), 0)
Zc = IIf(Sz = "s", 0, Val(Text1(6)))
Ye = Ye - IIf(Sz = "z", Val(Text1(6)), -Val(Text1(6)))
Bh = Bhp
Bz = Trim(Text1(7)): If Bz = "" Then Bz = " "
If strFs = "1" Then
strSz = IIf(Option1(0), "收入", "支出")
StrMsg = " 确实要将 " & Mc & " 的" & strSz & "信息存盘吗 ？ "
If MsgBox(StrMsg, 1 + 32 + 0, " 请 确 认 ") <> 1 Then
blnBx = False: Exit Sub
End If
Xh = Xh + 1
StrSQL = "INSERT Into " & StrT2 & "( Rq,Xh,Sz,Lb,Mc,Dj,Sl,Sr,Zc,Ye,Bh,Bz) " & _
" VALUES ( '" & Rq & "'," & Xh & "," & _
"'" & Sz & "','" & Lb & "','" & Mc & "', " & Dj & "," & _
Sl & "," & Sr & "," & Zc & "," & Ye & "," & Bh & ",'" & Bz & "')"
cnnTce.Execute StrSQL, , adCmdText
MSFlexGrid1.TextMatrix(MSFlexGrid1.Rows - 1, 7) = Format(Ye, "0.00 ")
Call P_xxxx
If blnBx Then
MyRs3.MoveFirst ' 置报销标志
Do While Not MyRs3.EOF
If MyRs3![Bh] = Bhp Then
MyRs3![Bx] = "B"
MyRs3![Bz] = Rq
MyRs3.Update
Exit Do
End If
MyRs3.MoveNext
Loop
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
End If
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 & " 行 " & Trim(Text1(1)) & " 的相关资料修改存盘吗 ？ "
If MsgBox(StrMsg, 1 + 32 + 0, " 请 确 认 ") = 1 Then
StrSQL = "SELECT * FROM " & StrT2 & _
" WHERE Rq ='" & Rqp & "' And Xh=" & Xhp
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
If Sz <> Szp Or Je <> Jep Then Call P_reye ' 计算余额
Else
MsgBox " Not Find Datas .... ", 48, " Error": Exit Sub
End If
Call P_grid
End If
End If
Xh = Xhp
End If
blnBf = True
Call P_init
End Sub
Private Sub Command2_Click() ' 记帐
blnSp = True
Call P_init
Command2.Enabled = False
Call P_setb
Text1(6).SetFocus
blnSp = False
strFs = "1"
End Sub
Private Sub Command3_Click() ' 删除
StrMsg = " 确实要将第 " & intRo1 & " 行的相关资料删除吗 ？ "
If MsgBox(StrMsg, 1 + 32 + 0, " 请 确 认 ") = 1 Then
StrSQL = "DELETE FROM " & StrT2 & _
" WHERE Rq='" & Rqp & "' And Xh=" & Xhp
cnnTce.Execute StrSQL, , adCmdText
If blnBx Then ' 取消报销标志
Set MyRs4 = New Recordset
StrSQL = "SELECT * FROM " & StrT3 & " Where Bh = " & Bhp ' T_yf 表
MyRs4.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
N4 = MyRs4.RecordCount
If N4 > 0 Then
MyRs4![Bx] = "A"
MyRs4.Update
MyRs4.MoveNext
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
s = Trim(MyRs4![Bz])
n = Len(s)
For i = 1 To n
If Mid(s, i, 1) = " " Then n = n - i: Exit For
Next
MyRs4![Bz] = Right(s, n)
MyRs4.Update
MyRs4.MoveNext
Loop
MyRs4.Close
Else
MsgBox " Not Find Datas ... ", 48, " Error": Exit Sub
End If
blnBx = False
End If
Call P_reye
Call P_grid
blnBf = True
End If
End Sub
Private Sub P_reye() ' 重算余额
StrSQL = "SELECT Rq,Xh,Sr,Zc,Ye FROM " & StrT2 & _
" WHERE Rq Like '" & Left(Rqp, 7) & "%'" & _
" Order By Rq,Xh"
Set MyRs0 = New Recordset ' And Xh>=" & arrZm(intRo1 - 1, 0)
MyRs0.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
N0 = MyRs0.RecordCount
If N0 > 0 Then
MyRs0.MoveFirst
Ye = MyRs0![Ye]
MyRs0.MoveNext
Do While Not MyRs0.EOF
'MsgBox MyRs0![Rq] & " " & MyRs0![Xh] & " " & Ye & " " & MyRs0![Sr] & " " & MyRs0![Zc]
Ye = Ye + MyRs0![Sr] - MyRs0![Zc]
MyRs0![Ye] = Ye
MyRs0.Update
MyRs0.MoveNext
Loop
MyRs0.Close
Else
MsgBox " Not Find Datas .... ", 48, " Error": Exit Sub
End If
End Sub
Private Sub Command4_Click() ' 退出
Frame1.Visible = False
With MSFlexGrid1
strFs = "0"
intRos = 30
.Top = 360
.Height = 225 * IIf(intTs > intRos, 31, intTs + 2) + 90
.Col = 8: .ColWidth(8) = 2100 - IIf(.Rows > intRos, 270, 0)
Label9.Top = .Top + .Height + 200
Command5.Top = Label9.Top
Command6.Top = Label9.Top
For j = 2 To .Cols - 1
.TextMatrix(.Rows - 1, j) = ""
Next
End With
Command5.Visible = True
Command6.Visible = True
End Sub
Private Sub Command5_Click()
Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next ' 关闭记录集，释放对象
MyRs1.Close: Set MyRs1 = Nothing
MyRs2.Close: Set MyRs2 = Nothing
MyRs3.Close: Set MyRs3 = Nothing
MyDb2.Close: Set MyDb2 = Nothing
Exit Sub
If blnBf Then Call P_bakdb
End Sub
Private Sub P_bakdb() ' 备份
strSname = App.Path & StrDir & Db_Name2
strDname = App.Path & StrDir & "\Bak_" & "01" & ".mdb"
On Error GoTo Er1
FileCopy strSname, strDname
Exit Sub
Er1:
MsgBox "Error #" & Str(Err.Number) & " at Line " & Str(Erl) & _
" - " & Err.Description & " - reportted by " & Err.Source
MsgBox strSname & strDname & " 数据备份失败 ... ", 48, " Error "
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -