📄 frmblock.frm
字号:
VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.Form frmBlock
BorderStyle = 0 'None
Caption = "Form1"
ClientHeight = 2250
ClientLeft = 0
ClientTop = 0
ClientWidth = 4515
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 2250
ScaleWidth = 4515
ShowInTaskbar = 0 'False
StartUpPosition = 2 '屏幕中心
Begin VB.Timer Timer1
Interval = 500
Left = 1680
Top = 840
End
Begin VB.TextBox txtCode
Appearance = 0 'Flat
BackColor = &H00FFFFFF&
Height = 300
Left = 990
TabIndex = 0
Top = 1830
Visible = 0 'False
Width = 1770
End
Begin MSCommLib.MSComm msBlock
Left = 3720
Top = 960
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
DTREnable = -1 'True
End
Begin VB.Image cmdCancel
Height = 270
Left = 3630
Picture = "frmBlock.frx":0000
Stretch = -1 'True
Top = 1845
Visible = 0 'False
Width = 750
End
Begin VB.Image cmdOk
Height = 270
Left = 2865
Picture = "frmBlock.frx":031A
Stretch = -1 'True
Top = 1845
Visible = 0 'False
Width = 750
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "请刷卡"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 180
Left = 240
TabIndex = 1
Top = 240
Width = 585
End
Begin VB.Shape Shape1
BorderColor = &H00000000&
Height = 270
Left = 240
Top = 1830
Width = 750
End
Begin VB.Image Image2
Height = 270
Left = 225
Picture = "frmBlock.frx":0646
Stretch = -1 'True
Top = 1830
Width = 750
End
Begin VB.Image imgBack
Height = 2250
Left = 0
Picture = "frmBlock.frx":09B9
Top = 0
Width = 4500
End
End
Attribute VB_Name = "frmBlock"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'API与常量定义
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private m_Code As String '卡号
Private Sub Inits()
'过 程 名: Inits()
'功 能: 对界面、控件等初始化
'编 写 者: 陶和平
'编写日期: 2005.1.14
Initiate
End Sub
Private Sub LoadData()
'过 程 名: LoadData()
'功 能: 加载数据
'编 写 者: 陶和平
'编写日期: 2005.1.14
End Sub
Public Sub Initiate()
'过 程 名: Initiate()
'功 能: 对端口进行初始化
'参 数:
'编 写 者: 陶和平
'编写日期: 2005.2.2
On Error GoTo err
With msBlock
.RThreshold = 9 '9位开始判断，若修改存储内容，则应修改此处长度
.InBufferSize = 1024
.CommPort = 1
.Settings = "9600,n,8,1"
.PortOpen = True
.InputLen = 0
.InBufferCount = 0
strcardno = ""
End With
Exit Sub
err:
WriteErr True, "初始化硬件出现错误", "Initiate", err.Description
End Sub
Private Sub SendCommand()
'过 程 名: SendCommand()
'功 能: 发送读取指令
'参 数:
'编 写 者: 陶和平
'编写日期: 2005.2.2
MS.Output = Chr(27) + Chr(48)
MS.Output = Chr(27) + Chr(93) '读磁道2(ESC + ])
End Sub
Public Sub WriteErr(Optional ShowErr As Boolean = True, _
Optional strMeErr As String = "", _
Optional strSourse As String = "", _
Optional strDescription As String = "")
'函 数 名: WriteErr()
'功 能: 将错误信息写入log文件中
'参 数: ShowErr 是否弹出错误对话框
' strMeErr 程序员描述信息
' strSourse 来源于那个模块(程序员描述)
' strDescription 系统提示信息
'编 写 者: 陶和平
'编写日期: 2005.2.2
On Error Resume Next
Dim strMsg As String
If ShowErr = True Then
strMsg = "错误描述: " & strMeErr & vbCrLf & _
"系统描述: " & strDescription & vbCrLf & _
"错误来源: " & strSourse
MsgBox strMsg, vbCritical, "出错了"
End If
Open App.Path & "\MSBlock.log" For Append As #1
Print #1, "==============================================="
Print #1, "记录 创 建于: " & CStr(Now)
Print #1, "错 误 来 自: " & strSourse
Print #1, "系统错误信息:" & strDescription
Print #1, "程序员错误信息:" & strMeErr
Print #1, "==============================================="
Close #1
End Sub
Private Sub cmdCancel_Click()
g_Code = ""
Unload Me
End Sub
Private Sub cmdOk_Click()
If Trim(txtCode.Text) = "" Then
MsgBox "请输入代码!", vbInformation, "提示"
Exit Sub
Else
g_Code = txtCode.Text
Unload Me
End If
End Sub
Private Sub Form_Load()
Inits '初始化
LoadData '加载数据
End Sub
Private Sub imgBack_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End If
End Sub
Private Sub imgBack_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Shape1.BorderColor = &H0&
End Sub
Private Sub Image2_Click()
txtCode.Visible = Not txtCode.Visible
cmdOk.Visible = Not cmdOk.Visible
cmdCancel.Visible = Not cmdCancel.Visible
End Sub
Private Sub Image2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Shape1.BorderColor = &HFF&
End Sub
Private Sub msBlock_OnComm()
'Comm接收指令
If msBlock.CommEvent <> 1 Then '在传输缓冲区中有比 Sthreshold 数少的字符
If msBlock.PortOpen = True Then
m_Code = ""
m_Code = msBlock.Input
'去除控制字符
m_Code = Replace(Replace(m_Code, Chr(27), ""), Chr(28), "")
'去除空格、A、s、？
m_Code = Trim(Replace(Replace(Replace(Replace(m_Code, "?", ""), "s", ""), "A", ""), ";", ""))
If m_Code = "rq" Then '刷卡错误！
'关闭串口
msBlock.PortOpen = False
Initiate
SendCommand '重新发送读取指令
Exit Sub
End If
If Len(m_Code) < 5 Then
'关闭串口
msBlock.PortOpen = False
Initiate
SendCommand '重新发送读取指令
Exit Sub
End If
End If
End If
End Sub
Private Sub Timer1_Timer()
If Label1.Caption = "请刷卡......" Then
Label1.Caption = "请刷卡"
Else
Label1.Caption = Label1.Caption & "."
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -