📄 ucexit.ctl
字号:
VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.UserControl ucExit
BackColor = &H80000005&
ClientHeight = 5850
ClientLeft = 0
ClientTop = 0
ClientWidth = 8655
ScaleHeight = 5850
ScaleWidth = 8655
Begin VB.Frame fraBody
BackColor = &H80000005&
Height = 5400
Left = 120
TabIndex = 0
Top = 210
Width = 8310
Begin VB.Timer Timer1
Interval = 1000
Left = 7110
Top = 3405
End
Begin VB.TextBox txtPkNO
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 2250
TabIndex = 15
Top = 945
Width = 2490
End
Begin VB.TextBox txtEnterTime
Enabled = 0 'False
Height = 375
Left = 2250
TabIndex = 13
Top = 1530
Width = 2490
End
Begin VB.TextBox txtCost
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000C0&
Height = 375
Left = 2250
TabIndex = 11
Top = 2715
Width = 2490
End
Begin VB.CommandButton cmdCalculate
Caption = "计算"
Height = 375
Left = 5070
TabIndex = 8
Top = 4830
Width = 1095
End
Begin VB.CommandButton CmdRecord
Caption = "确定"
Enabled = 0 'False
Height = 375
Left = 6570
TabIndex = 2
Top = 4830
Width = 1095
End
Begin VB.TextBox TextRemark
Height = 1035
Left = 2250
MultiLine = -1 'True
TabIndex = 1
Top = 3300
Width = 4215
End
Begin MSComCtl2.DTPicker dtpExitTime
Height = 405
Left = 2250
TabIndex = 3
Top = 2130
Width = 2490
_ExtentX = 4392
_ExtentY = 714
_Version = 393216
CustomFormat = "yyyy-MM-dd hh:mm:ss"
Format = 169082883
CurrentDate = 39236
End
Begin VB.Label Label8
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "（点击“计算”按钮自动获取入场时间和计算机关费用）"
ForeColor = &H000000FF&
Height = 180
Left = 825
TabIndex = 17
Top = 4530
Width = 4500
End
Begin VB.Label Label1
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "编号："
ForeColor = &H00000000&
Height = 255
Left = 885
TabIndex = 16
Top = 1005
Width = 855
End
Begin VB.Label Label7
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "（元）"
Height = 180
Left = 4890
TabIndex = 14
Top = 2760
Width = 540
End
Begin VB.Label Label6
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "入场时间："
ForeColor = &H00000000&
Height = 180
Left = 885
TabIndex = 12
Top = 1627
Width = 900
End
Begin VB.Label Label4
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "费用："
ForeColor = &H00000000&
Height = 255
Left = 885
TabIndex = 10
Top = 2775
Width = 855
End
Begin VB.Label Label3
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "（条形码扫描或手工输入）"
Height = 180
Left = 4905
TabIndex = 9
Top = 990
Width = 2160
End
Begin VB.Label lblLogin
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "车辆出场登记"
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 285
Index = 0
Left = 3270
TabIndex = 6
Top = 315
Width = 1800
End
Begin VB.Label Label5
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "备注：（可选）"
ForeColor = &H00000000&
Height = 720
Left = 870
TabIndex = 5
Top = 3360
Width = 1275
End
Begin VB.Label Label2
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "出场时间："
ForeColor = &H00000000&
Height = 180
Left = 885
TabIndex = 4
Top = 2242
Width = 900
End
Begin VB.Label lblLogin
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "车辆出场登记"
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00808080&
Height = 285
Index = 1
Left = 3285
TabIndex = 7
Top = 300
Width = 1800
End
End
End
Attribute VB_Name = "ucExit"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private m_bIsReadyToSubmit As Boolean '只有当此变量为True时才可以提交
'============================================
'功能：根据起止时间计算停车费用
'参数: EnterTime: [IN], 入场时间
' ExitTime: [IN], 出场时间
'返回值: 所需费用
'============================================
Private Function CalculateParkingCost(EnterTime As Date, _
ExitTime As Date) As Currency
Dim nHour As Double
''直接利用DateDiff函数将时差换算为小时, 然后根据费用规则计算, 但此时会四舍五入
nHour = DateDiff("h", EnterTime, ExitTime)
If nHour < 0 Then
CalculateParkingCost = -1
Exit Function
Else
'应用收费规则，在演示版中这里对收费规则做了简化处理，假设每小时 2 元
CalculateParkingCost = nHour * 2
End If
End Function
'============================================
'功能：获取车辆入场时间，并计算停车费用
'============================================
Private Sub cmdCalculate_Click()
Dim rsObj As New adodb.Recordset
Dim SqlStr As String
Dim szPkNO As String
Dim Remark As String
Dim sNow As String
Dim szEnterTime As String
Dim UsrID As String
szPkNO = Replace(txtPkNO.Text, "'", "''")
SqlStr = "SELECT * FROM ParkingInfo WHERE ParkingNO ='" & szPkNO & "'"
Call rsObj.Open(SqlStr, DBCnn, adOpenKeyset, adLockReadOnly)
If rsObj.RecordCount <= 0 Then
MsgBox "输入的ID号有误， 没有查到入场记录，请重试...", vbExclamation
Exit Sub
End If
txtEnterTime.Text = rsObj("EnterTime")
TextRemark.Text = rsObj("Remark")
'如果输出的编号已经出场了，那么只显此编号信息，
Dim bAlreadyExit As Boolean
bAlreadyExit = IIf(IsNull(rsObj("ExitTime")), False, True)
If bAlreadyExit Then
txtCost.Text = rsObj("Charge")
txtCost.Enabled = False
dtpExitTime.Enabled = False
Timer1.Enabled = False
dtpExitTime.Value = rsObj("ExitTime")
MsgBox "输入的ID号已经出场了，下面将显示它的详细信息", vbInformation
Else
txtCost.Text = CalculateParkingCost(rsObj("EnterTime"), Now)
txtCost.Enabled = True
'如果计算成功， 那么可以提交车辆出场信息了
m_bIsReadyToSubmit = True
CmdRecord.Enabled = True
dtpExitTime.Enabled = True
Timer1.Enabled = True
End If
End Sub
'============================================
'功能：记录车辆出场信息
'============================================
Private Sub CmdRecord_Click()
Dim AddGuest As New adodb.Recordset
Dim SqlStr As String
Dim GuestSex As String
Dim Remark As String
Dim sNow As String
Dim GuestName As String
Dim GuestReson As String
Dim UsrID As String
'此句可以防止用户恶意通过更改按钮Enalbe属性来强行提交
If m_bIsReadyToSubmit = False Then
Exit Sub
End If
GuestName = Replace(Trim(txtPkNO.Text), "'", "''")
UsrID = Replace(UserNow.ID, "'", "''")
Remark = Replace(Trim(TextRemark.Text), "'", "''")
sNow = Format(Now, "yyyy-mm-dd hh:mm:ss")
SqlStr = "UPDATE ParkingInfo"
SqlStr = SqlStr & " SET ExitTime = #" & sNow & "#,"
SqlStr = SqlStr & " Charge = " & txtCost.Text & ","
SqlStr = SqlStr & " Remark = '" & TextRemark.Text & "',"
SqlStr = SqlStr & " ChargeRecID = '" & UsrID & "'"
SqlStr = SqlStr & " WHERE ParkingNO='" & txtPkNO.Text & "'"
DBCnn.Execute SqlStr
'重新初始化界面
Call UserControl_Initialize
'记录该操作
AddRec (1)
'提示用户
MsgBox "操作记录成功！"
End Sub
Private Sub Timer1_Timer()
dtpExitTime.Value = Now
End Sub
Private Sub txtPkNO_Change()
'如果改变编号， 那么只有在按了“计算”之后才能提交车辆出场信息
m_bIsReadyToSubmit = False
CmdRecord.Enabled = False
End Sub
Private Sub UserControl_Hide()
Timer1.Enabled = False
End Sub
'============================================
'功能：控件初始化
'============================================
Private Sub UserControl_Initialize()
'初始值，不可以提交车辆出场信息
m_bIsReadyToSubmit = False
CmdRecord.Enabled = False
txtPkNO.Text = Format(Year(Now), "0000") + Format(Month(Now), "00") + Format(Day(Now), "00")
dtpExitTime.Value = Now
txtCost.Text = ""
TextRemark.Text = ""
End Sub
'============================================
'功能：响应 用户控件的Resize事件，使fraBody自动居中
'============================================
Private Sub UserControl_Resize()
Dim nLeft, nTop As Integer
'计算新的Left和Top
nLeft = (UserControl.Width - fraBody.Width) / 2
nTop = (UserControl.Height - fraBody.Height) / 2
'只有当新的Left和Top > 0 时才移动fraBody
fraBody.Left = IIf(nLeft > 0, nLeft, 0)
'fraBody.Top = IIf(nTop > 0, nTop, fraBody.Top)
End Sub
Private Sub UserControl_Show()
Timer1.Enabled = True
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -