📄 frmcheck.frm
字号:
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form frmCheck
BorderStyle = 3 'Fixed Dialog
Caption = "收款窗口"
ClientHeight = 3750
ClientLeft = 45
ClientTop = 330
ClientWidth = 7860
Icon = "frmCheck.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3750
ScaleWidth = 7860
ShowInTaskbar = 0 'False
Begin VB.TextBox txtRecord
ForeColor = &H000080FF&
Height = 285
Left = 180
Locked = -1 'True
TabIndex = 0
Text = "上网时间列表"
Top = 3300
Width = 7485
End
Begin VB.CommandButton cmdCancel
Cancel = -1 'True
Height = 465
Left = 6030
Picture = "frmCheck.frx":000C
Style = 1 'Graphical
TabIndex = 2
Top = 855
Width = 1395
End
Begin VB.CommandButton cmdCheck
Height = 465
Left = 6030
Picture = "frmCheck.frx":1778
Style = 1 'Graphical
TabIndex = 1
Top = 345
Width = 1395
End
Begin MSFlexGridLib.MSFlexGrid Grid1
Height = 2760
Left = 180
TabIndex = 3
Top = 345
Width = 5325
_ExtentX = 9393
_ExtentY = 4868
_Version = 393216
Cols = 3
BackColor = 16777215
BackColorSel = 14737632
ForeColorSel = 0
BackColorBkg = 14737632
AllowBigSelection= 0 'False
FocusRect = 0
ScrollBars = 2
SelectionMode = 1
BorderStyle = 0
Appearance = 0
End
Begin VB.Line Line1
BorderColor = &H00808080&
Index = 1
X1 = 180
X2 = 5505
Y1 = 315
Y2 = 315
End
Begin VB.Line Line4
BorderColor = &H000080FF&
X1 = 5805
X2 = 7500
Y1 = 2190
Y2 = 2190
End
Begin VB.Image Image1
Height = 1350
Left = 45
Picture = "frmCheck.frx":2EE4
Top = 330
Visible = 0 'False
Width = 1350
End
Begin VB.Label lblXF
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "消费:40元"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00C000C0&
Height = 240
Left = 5805
TabIndex = 6
Top = 2715
Width = 1080
End
Begin VB.Label lblSW
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "上网:10元"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00808000&
Height = 240
Left = 5805
TabIndex = 5
Top = 2355
Width = 1080
End
Begin VB.Label lblHJ
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "合计:50元"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 240
Left = 5820
TabIndex = 4
Top = 1845
Width = 1080
End
Begin VB.Line Line1
BorderColor = &H00808080&
Index = 4
X1 = 180
X2 = 7650
Y1 = 3240
Y2 = 3240
End
Begin VB.Line Line1
BorderColor = &H00FFFFFF&
Index = 3
X1 = 180
X2 = 7635
Y1 = 3255
Y2 = 3255
End
Begin VB.Line Line3
BorderColor = &H00FFFFFF&
X1 = 165
X2 = 5520
Y1 = 3120
Y2 = 3120
End
Begin VB.Line Line2
BorderColor = &H00FFFFFF&
X1 = 5505
X2 = 5505
Y1 = 330
Y2 = 3120
End
Begin VB.Line Line1
BorderColor = &H00808080&
Index = 2
X1 = 165
X2 = 165
Y1 = 330
Y2 = 3120
End
Begin VB.Shape Shape1
FillColor = &H00C0FFFF&
FillStyle = 0 'Solid
Height = 1590
Left = 5640
Shape = 4 'Rounded Rectangle
Top = 1545
Width = 2040
End
End
Attribute VB_Name = "frmCheck"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub ConfigGrid()
On Error GoTo Err_grid
sJE = 0
Grid1.Visible = False
Grid1.Clear
Grid1.Cols = 5
Grid1.FormatString = "^ .. |^ 物品名称 |^ 数量 |^ 单价 |^ 金额 "
Grid1.ColWidth(0) = 680
Grid1.ColWidth(1) = 1520
Grid1.ColWidth(2) = 800
Grid1.ColWidth(3) = 800
Grid1.ColWidth(4) = 1550
Dim DB As Database, Ef As Recordset, HH As Integer, DelNo As Long
Dim shiftStr As String, shiftStrL As String, shiftStrR As String, shiftNum As Integer, ili As Integer, TempStr As String, sureStr As String, Qy As Integer
Set DB = OpenDatabase(ConData, False, False, ConStr)
'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
Set Ef = DB.OpenRecordset("Customer", dbOpenTable)
DelNo = Ef.RecordCount
Grid1.Rows = Ef.RecordCount + 2
Dim GridColor As Long
Set Ef = DB.OpenRecordset("Select * From Customer Where 房号='" & sJH & "'", dbOpenDynaset)
HH = 1
Do While Not Ef.EOF()
' 已送与未送区别
If Not IsNull(Ef.Fields(7).Value) Then
If Ef.Fields(7).Value = "已送" Then
GridColor = &H8000&
Else
GridColor = &H80FF&
End If
End If
Grid1.Row = HH
Grid1.Col = 0
Grid1.CellAlignment = 4
Grid1.CellForeColor = GridColor
If Not IsNull(Ef.Fields(0).Value) Then
Grid1.Text = Ef.Fields(0).Value
End If
Grid1.Row = HH
Grid1.Col = 1
Grid1.CellAlignment = 1
Grid1.CellForeColor = GridColor
If Not IsNull(Ef.Fields(1).Value) Then
Grid1.Text = Ef.Fields(1).Value
End If
Grid1.Row = HH
Grid1.Col = 2
Grid1.CellAlignment = 1
Grid1.CellForeColor = GridColor
If Not IsNull(Ef.Fields(4).Value) Then
Grid1.Text = Ef.Fields(4).Value
End If
Grid1.Row = HH
Grid1.Col = 3
Grid1.CellAlignment = 1
Grid1.CellForeColor = GridColor
If Not IsNull(Ef.Fields(3).Value) Then
Grid1.Text = Ef.Fields(3).Value
End If
Grid1.Row = HH
Grid1.Col = 4
Grid1.CellAlignment = 1
Grid1.CellForeColor = GridColor
If Not IsNull(Ef.Fields(5).Value) Then
Grid1.Text = Ef.Fields(5).Value
If GridColor = &H8000& Then '绿色时添加
sJE = sJE + Val(Grid1.Text)
End If
End If
Ef.MoveNext
HH = HH + 1
Loop
Ef.Close
DB.Close
Grid1.Col = 1
Grid1.Row = 1
Grid1.ColSel = 4
Grid1.Visible = True
Exit Sub
Err_grid:
MsgBox "网格 配置错误! " & vbCrLf & vbCrLf & Err.Description, vbCritical
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdCheck_Click()
Call CheckIt '结帐
End Sub
Private Sub Form_Load()
FC = True
On Error GoTo Err_init
Screen.MousePointer = 11
Dim L As Long, T As Long
L = Val(GetSetting(App.EXEName, "Option", "Check_L", 2000))
T = Val(GetSetting(App.EXEName, "Option", "Check_T", 2000))
Me.left = L
Me.tOp = T
Me.Caption = sJH & " 收款窗口 ： 现在是 [ " & Format(Date, "yyyy/mm/dd") & " " & Time & " ] "
' 配置网格
ConfigGrid
' 提取开始计费数据
ConfigJF
Screen.MousePointer = 0
Exit Sub
Err_init:
MsgBox "表单加载错误! " & vbCrLf & vbCrLf & Err.Description, vbCritical
End Sub
Private Sub ConfigJF()
On Error GoTo Err_JF
Result = ""
If sJH = "" Then
sJH = "01"
End If
AppName = Val(sJH)
KeyName = "Start"
ReadInI
StartJF = CDate(Result)
EndJF = Now
OnlineSJ = DateDiff("n", StartJF, EndJF)
txtRecord = "自：" & StartJF & " 到 " & EndJF & " ，共 " & OnlineSJ & " 分钟!"
' 计算上网费用
Result = ""
AppName = "Option"
KeyName = "JE"
ReadInI
swDJ = Result
If Result = "" Then
swDJ = 4
End If
Result = ""
swF = OnlineSJ * swDJ / 60
' 显示上网
lblSW.Caption = "上网:" & Format(swF, "###0.0") & "元"
' 显示消费
lblXF.Caption = "消费:" & sJE & "元"
' 显示合计
lblHJ.Caption = "合计:" & Format(swF + sJE, "###0.0") & "元"
Exit Sub
Err_JF:
MsgBox "计费错误! " & vbCrLf & vbCrLf & Err.Description, vbCritical
End Sub
Private Sub Form_Paint()
Dim intX As Integer
Dim intY As Integer
For intX = 0 To frmCheck.Width Step Image1.Width
For intY = 0 To frmCheck.Height Step (Image1.Height - 12)
PaintPicture Image1, intX, intY
Next intY
Next intX
End Sub
Private Sub CheckIt()
On Error GoTo Err_Check
' 1/加入消费历史表,2/清除消费记录
TransRecord sJH
' 3/添加到上网记录
AddRecord sJH, "机号", StartJF, "开机时间", EndJF, "结束时间", swDJ, "单价", OnlineSJ, "时间", swF, "上网金额", sJE, "消费总金额", swF + sJE, "应付总金额", "Online"
' 4/填充Server项目 5/恢复启动数据
Dim curIndex As Integer
curIndex = Val(sJH)
frmServer.lvComputer.ListItems(curIndex).SmallIcon = frmServer.ImageList1.ListImages(1).Key
frmServer.lvComputer.ListItems(curIndex).Text = "空闲"
frmServer.lvComputer.ListItems(curIndex).SubItems(3) = EndJF '计算使用分钟
frmServer.lvComputer.ListItems(curIndex).SubItems(4) = DateDiff("n", StartJF, EndJF)
frmServer.lvComputer.ListItems(curIndex).SubItems(5) = swDJ
frmServer.lvComputer.ListItems(curIndex).SubItems(6) = Format(swF, "###0.0")
frmServer.lvComputer.ListItems(curIndex).SubItems(7) = sJE
frmServer.lvComputer.ListItems(curIndex).SubItems(8) = Format(sJE + swF, "###0.0")
frmServer.tbToolBar.Buttons(2).Enabled = True
frmServer.tbToolBar.Buttons(4).Enabled = False
frmServer.tbToolBar.Buttons(3).Enabled = False
' 其它操作,计算单价等
AppName = Trim(Str(curIndex))
KeyName = "Start"
Value = ""
WriteInI '写数据
KeyName = "OtherXF"
Value = "0"
WriteInI '写数据
Unload Me
Exit Sub
Err_Check:
MsgBox "结帐错误! " & vbCrLf & vbCrLf & Err.Description, vbCritical
End Sub
Private Sub TransRecord(sComputer As String)
On Error GoTo Err_trans
Dim DB As Database
Dim sEXE As String
Set DB = OpenDatabase(ConData, False, False, ConStr)
'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
' SQL语言删除
sEXE = "Insert into CustomerHistory Select * From Customer Where 房号='" & sComputer & "'"
DBEngine.BeginTrans ' 进行事务操作
DB.Execute sEXE
sEXE = "Delete * From Customer Where 房号='" & sComputer & "'"
DB.Execute sEXE
DBEngine.CommitTrans
DB.Close
Exit Sub
Err_trans:
MsgBox "数据传送错误! " & vbCrLf & vbCrLf & Err.Description, vbCritical
End Sub
Private Sub AddRecord(sWP1 As String, sFields1 As String, sWP2 As Variant, sFields2 As String, _
sWP3 As Variant, sFields3 As String, sWP4 As Variant, sFields4 As String, sWP5 As Variant, sFields5 As String, sWP6 As Variant, sFields6 As String, _
sWP7 As Variant, sFields7 As String, sWP8 As Variant, sFields8 As String, sTable As String)
On Error GoTo Err_Add
Dim DB As Database
Dim sEXE As String
Set DB = OpenDatabase(ConData, False, False, ConStr)
'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
' SQL语言删除
sEXE = "Insert into " & sTable & " (" & sFields1 & "," & sFields2 & "," & sFields3 & "," & sFields4 & "," & sFields5 & "," & sFields6 & "," & sFields7 & _
"," & sFields8 & ",日期) values('" & sWP1 & "',#" & sWP2 & "#,#" & sWP3 & "#," & sWP4 & "," & sWP5 & "," & sWP6 & "," & sWP7 & "," & sWP8 & ",#" & Date & "#)"
DBEngine.BeginTrans ' 进行事务操作
DB.Execute sEXE
DBEngine.CommitTrans
DB.Close
Exit Sub
Err_Add:
MsgBox "记录添加错误! " & vbCrLf & vbCrLf & Err.Description, vbCritical
End Sub
Private Sub Form_Unload(Cancel As Integer)
FC = False
SaveSetting App.EXEName, "Option", "Check_L", Me.left
SaveSetting App.EXEName, "Option", "Check_T", Me.tOp
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -