ucenter.ctl
来自「<Visual Basic 数据库开发实例精粹（第二版）>一书首先介」· CTL 代码 · 共 304 行
CTL
304 行
VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.UserControl ucEnter
BackColor = &H80000005&
ClientHeight = 5400
ClientLeft = 0
ClientTop = 0
ClientWidth = 9075
ScaleHeight = 5400
ScaleWidth = 9075
Begin VB.Frame fraBody
BackColor = &H80000005&
Height = 4665
Left = 285
TabIndex = 0
Top = 255
Width = 8310
Begin VB.Timer Timer1
Interval = 1000
Left = 7230
Top = 2490
End
Begin VB.TextBox txtRemark
Height = 1245
Left = 2175
MultiLine = -1 'True
TabIndex = 3
Top = 2625
Width = 4215
End
Begin VB.CommandButton CmdRecord
Caption = "确定"
Height = 375
Left = 6255
TabIndex = 2
Top = 4065
Width = 1110
End
Begin MSComCtl2.DTPicker dtpEnter
Height = 405
Left = 2175
TabIndex = 1
Top = 1920
Width = 2490
_ExtentX = 4392
_ExtentY = 714
_Version = 393216
CustomFormat = "yyyy-MM-dd hh:mm:ss"
Format = 169082883
CurrentDate = 39236
End
Begin VB.Label Label7
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "（自动生成，只读）"
Height = 180
Left = 4860
TabIndex = 13
Top = 765
Width = 1620
End
Begin VB.Label Label6
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "当日序号："
ForeColor = &H00000000&
Height = 180
Left = 855
TabIndex = 12
Top = 810
Width = 900
End
Begin VB.Label labDailyID
BackStyle = 0 'Transparent
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 2175
TabIndex = 11
Top = 750
Width = 2490
End
Begin VB.Label labIDVal
BackStyle = 0 'Transparent
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 2175
TabIndex = 10
Top = 1320
Width = 2490
End
Begin VB.Label Label1
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "编号："
ForeColor = &H00000000&
Height = 255
Left = 885
TabIndex = 9
Top = 1380
Width = 855
End
Begin VB.Label Label3
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "（自动生成，只读）"
Height = 180
Left = 4890
TabIndex = 8
Top = 1335
Width = 1620
End
Begin VB.Label Label2
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "入场时间："
ForeColor = &H00000000&
Height = 180
Left = 885
TabIndex = 6
Top = 2025
Width = 900
End
Begin VB.Label Label5
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "备注：（可选）"
ForeColor = &H00000000&
Height = 720
Left = 885
TabIndex = 5
Top = 2685
Width = 1275
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 = 315
Index = 0
Left = 3255
TabIndex = 4
Top = 285
Width = 1800
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 = "ucEnter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'============================================
'功能：自动生成编号
'参数: nDailyID: [OUT], 返回当日下一个DailyID
' szPkID: [OUT], 返回当日下一个编号(ParkingNO)
'============================================
Private Sub AutoGenerateParkingNO(ByRef nDailyID As Long, _
ByRef szPkID As String)
Dim rsNext As New adodb.Recordset
nDailyID = 1
On Error Resume Next
If Not DBCnn.State = adodb.adStateOpen Then
Exit Sub
End If
Call rsNext.Open("SELECT MAX(DailyID) AS MaxPkID FROM ParkingInfo WHERE EnterTime > Date()", DBCnn, adOpenKeyset, adLockReadOnly)
If rsNext.RecordCount <= 0 Then
nDailyID = 1
Else
nDailyID = rsNext("MaxPkID") + 1
End If
'注意下面对Format函数的使用
szPkID = Format(Year(Now), "0000") + Format(Month(Now), "00") + Format(Day(Now), "00") + Format(nDailyID, "0000")
End Sub
'============================================
'功能：添加新的车辆入场记录
'============================================
Private Sub CmdRecord_Click()
Dim SqlStr As String
Dim DailyID As String
Dim Remark As String
Dim sNow As String
Dim szParkingNO As String
Dim UsrID As String
szParkingNO = Replace(Trim(labIDVal.Caption), "'", "''")
DailyID = labDailyID.Caption
UsrID = Replace(UserNow.ID, "'", "''")
sNow = Format(Now, "yyyy-mm-dd hh:mm:ss")
Remark = Replace(Trim(txtRemark.Text), "'", "''")
SqlStr = "INSERT INTO ParkingInfo"
SqlStr = SqlStr & "(ParkingNO, DailyID, EnterTime, ParkingRecID, Remark) "
SqlStr = SqlStr & "VALUES ('" & szParkingNO & "',"
SqlStr = SqlStr & DailyID & ","
SqlStr = SqlStr & "#" & sNow & "#,"
SqlStr = SqlStr & "'" & UsrID & "',"
SqlStr = SqlStr & "'" & Remark & "');"
DBCnn.Execute SqlStr
'重新初始化新值
Call UserControl_Initialize
'记录该操作
AddRec (1)
'提示用户
MsgBox "添加记录成功！"
End Sub
Private Sub Timer1_Timer()
dtpEnter.Value = Now
End Sub
Private Sub UserControl_Hide()
Timer1.Enabled = False
End Sub
Private Sub UserControl_Initialize()
Dim nDailyID As Long
Dim szPkID As String
Call AutoGenerateParkingNO(nDailyID, szPkID)
labDailyID.Caption = Format(nDailyID, "0000")
labIDVal.Caption = szPkID
dtpEnter.Value = Now
txtRemark.Text = ""
End Sub
'============================================
'功能：响应 用户控件的Resize事件，使fraBody自动居中
'============================================
Private Sub UserControl_Resize()
Dim nLeft, nTop As Integer
'计算新的Left值
nLeft = (UserControl.Width - fraBody.Width) / 2
'只有当新的Left和Top > 0 时才移动fraBody
fraBody.Left = IIf(nLeft > 0, nLeft, 0)
End Sub
Private Sub UserControl_Show()
Timer1.Enabled = True
End Sub
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?