📄 frmset.frm
字号:
EndProperty
Height = 492
Left = 3240
TabIndex = 4
Top = 4680
Width = 1692
End
Begin VB.Frame Frame1
Caption = "日期时间设置"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2292
Left = 3480
TabIndex = 0
Top = 240
Width = 5892
Begin VB.CommandButton Command2
Caption = "校对日期时间"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 492
Left = 3840
TabIndex = 3
Top = 1200
Width = 1692
End
Begin VB.CommandButton Command1
Caption = "读日期时间"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 492
Left = 3840
TabIndex = 2
Top = 600
Width = 1692
End
Begin VB.ListBox List1
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1488
Left = 360
TabIndex = 1
Top = 480
Width = 3252
End
End
Begin MSCommLib.MSComm MSComm1
Left = 9240
Top = 120
_ExtentX = 995
_ExtentY = 995
_Version = 393216
DTREnable = -1 'True
OutBufferSize = 1024
RTSEnable = -1 'True
InputMode = 1
End
End
Attribute VB_Name = "frmSet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private ReadStr As String
Dim stList As String
Dim stSend(100) As Byte
Dim stSendTmp(100) As Byte
'Dim rsLen As Integer
'Dim rsSend As Integer
Dim DataHex() As Byte
Dim rs As New ADODB.Recordset
Dim pscard As New ADODB.Recordset
Dim n As Integer
Dim sttxt As String
Dim psTempPathFile1 As String
Private Sub Command1_Click() '操作采集器
Dim pssql As String
DoType = 80
stList = "BA028038"
DSend (stList)
'Lab1.Caption = ""
'
'
'If Check1.value = 1 Then '校时
'
'End If
'
'
'
'If Check2.value = 1 Then '下载有效名单
'Lab1.Caption = "正在组织有效名单..."
'pssql = "select * from Full_UserDict where m1cardstate='启用' order by m1cardid"
'Set rs = GetRecordset(maSys_db, pssql)
'stList = ""
'stList = Format(CStr(rs.RecordCount), "00000000")
'Do While Not rs.EOF
' stList = stList & rs!m1cardid
' rs.MoveNext
'Loop
'rs.Close
'Lab1.Caption = "正在导入有效名单..."
'End If
'
'
'
'If Check3.value = 1 Then '下载记录
' psTempPathFile1 = App.Path + "\Current " + Format(Now, "yyyymmddhhmmss") + ".txt"
' Open psTempPathFile1 For Output As #2
' Lab2.Caption = "请等待..."
' Lab2.Refresh
' stList = "BD028813"
' n = 0
'
' DSend (stList)
'
'
'End If
'
'If Check4.value = 1 Then '删除采集器记录
'
'End If
'Lab1.Caption = ""
Exit Sub
Err2:
End Sub
'数据发送函数
Private Sub DSend(DataSend As String)
Dim i As Integer
Dim k As Integer
MSComm1.OutBufferCount = 0 '清除发送缓冲区
MSComm1.InBufferCount = 0 '清除接收缓冲区
MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
i = (Len(DataSend)) / 2
ReDim DataHex((i - 1)) As Byte
For k = 0 To (i - 1)
DataHex(k) = CByte("&H" & Right((Left(DataSend, (k + 1) * 2)), 2)) 'Asc(Right((Left(DataSend, k + 1)), 1)) '
Next k
'DataHex(0) = &H39
On Error GoTo Err2
MSComm1.Output = DataHex '发送数据
' List1.Clear
' rsSend = 1
Exit Sub
Err2:
Select Case err.Number '串口没有打开的出错提示
Case comPortNotOpen
MsgBox err.Description, vbInformation
Case Else
MsgBox "程序出错:" & "出错代码. " & err.Number & ": 出错提示信息: " & err.Description, vbInformation
End Select
End Sub
Private Sub Command4_Click() '设置设备ID
If Val(Text1.Text) = 0 Then Exit Sub
Text1.Text = Format(Val(Text1.Text), "0000")
stSendTmp(0) = &HBA
stSendTmp(1) = &H4
stSendTmp(2) = &H85
stSendTmp(3) = "&H" + Mid(Text1.Text, 1, 2)
stSendTmp(4) = "&H" + Mid(Text1.Text, 3, 2)
stSendTmp(5) = &H0
For n = 0 To 4
stSendTmp(5) = stSendTmp(5) Xor stSendTmp(n)
Next n
stList = ""
For n = 0 To 5
stList = stList + Right("00" + hex(stSendTmp(n)), 2)
Next n
'stList = "BA048511113b"
DSend (stList)
End Sub
Private Sub Command5_Click() '读设备ID
stList = "BA02863E"
DSend (stList)
End Sub
Private Sub Command6_Click()
Unload Me
End Sub
Private Sub Command7_Click() '设置通讯口参数
'取文件ID
If Combo1.Text = "COM1" Then
comPort = 1
Else
comPort = 2
End If
SaveRegKey HKEY_CURRENT_USER, "com", "comnumber", str(comPort)
If Combo2.Text = "" Then Exit Sub
comSet = Combo2.Text + ",N,8,1"
SaveRegKey HKEY_CURRENT_USER, "com", "comset", comSet
MsgBox "设置成功，如需继续操作，请重新进入该模块！", vbInformation + vbOKCancel, "提示信息"
End Sub
'数据有返回时的响应
Private Sub MSComm1_OnComm()
Dim DataRead() As Byte
Dim bytData As Variant '用来从接收缓冲区读取数据
Dim dispstr As String
On Error Resume Next
With MSComm1
Select Case .CommEvent
Case comEvReceive
ReadStr = ""
bytData = .Input
ReDim DataRead(UBound(bytData)) As Byte
For i = 0 To UBound(bytData)
DataRead(i) = bytData(i)
ReadStr = ReadStr & Hex2((DataRead(i)))
Next i
'If DataRead(4) <> 170 Then
'Text1.Text = Text1.Text & ReadStr '将读取出来的数据发送到文本框中显示出来
sttxt = sttxt + ReadStr
DoType = Mid(sttxt, 5, 2)
If DoType < "80" Or DoType > "90" Then sttxt = "": MsgBox "命令错误": Exit Sub
Select Case DoType
Case "80" '读日期时间
If Len(sttxt) > 22 Then sttxt = "": MsgBox "读日期时间错误": Exit Sub
If Len(sttxt) = 22 Then
List1.Clear
List1.AddItem ""
List1.AddItem "日期：" + Mid(sttxt, 9, 2) + "-" + Mid(sttxt, 11, 2) + "-" + Mid(sttxt, 13, 2)
List1.AddItem ""
List1.AddItem "时间：" + Mid(sttxt, 15, 2) + ":" + Mid(sttxt, 17, 2) + ":" + Mid(sttxt, 19, 2)
sttxt = ""
End If
Case "81" '设置日期
If Len(sttxt) > 10 Then sttxt = "": MsgBox "设置日期错误": Exit Sub
If Len(sttxt) = 10 Then
List1.Clear
List1.AddItem ""
List1.AddItem "设置日期成功"
'DoType = 81
stList = ""
For n = 0 To 6
stList = stList + Right("00" + hex(stSend(n)), 2)
Next n
sttxt = ""
DSend (stList)
End If
Case "82" '设置时间
If Len(sttxt) > 10 Then sttxt = "": MsgBox "设置时间错误": Exit Sub
If Len(sttxt) = 10 Then
List1.AddItem ""
List1.AddItem "设置时间成功"
sttxt = ""
End If
Case "85" '设置设备ID
If Len(sttxt) > 10 Then sttxt = "": MsgBox "设置设备ID错误": Exit Sub
If Len(sttxt) = 10 Then
MsgBox "设置成功！"
sttxt = ""
End If
Case "86" '读设备ID
If Len(sttxt) > 14 Then sttxt = "": MsgBox "读设备ID错误错误": Exit Sub
If Len(sttxt) = 14 Then
Text1.Text = Mid(sttxt, 9, 4)
sttxt = ""
End If
Case "88" '设置KEYA
If Len(sttxt) > 10 Then sttxt = "": MsgBox "设置密码A错误": Exit Sub
If Len(sttxt) = 10 Then
stList = ""
For n = 0 To 11
stList = stList + Right("00" + hex(stSend(n)), 2)
Next n
sttxt = ""
DSend (stList)
End If
Case "8A"
If Len(sttxt) > 10 Then sttxt = "": MsgBox "设置密码B错误": Exit Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -