Option Explicit
'*************************************************************************
'* 链接卡片操作函数库
'*************************************************************************
Public Declare Function mif_selecom Lib "LCRFRW_SDK.dll" (ByVal com As Long, ByVal baud As Long) As Long
Public Declare Function mif_selecard Lib "LCRFRW_SDK.dll" (ByVal ncardtype As Long) As Long
Public Declare Function mif_closecom Lib "LCRFRW_SDK.dll" () As Long
Public Declare Function tem_writedoorcard_sdk Lib "LCRFRW_SDK.dll" (ByVal buffer1$, ByVal buffer2$, ByVal xh As Long, ByVal sjdw As Long, ByVal sjlenght As Long, ByVal gs As Long, ByVal p_nLockAP As Long) As Long
Public Declare Function tem_readdoorcard_sdk Lib "LCRFRW_SDK.dll" (ByVal buffer1$, ByVal buffer2$, ByVal p_nLockAP As Long) As Long
Public Declare Function tem_readtimercard_sdk Lib "LCRFRW_SDK.dll" (ByVal fksj$, ByVal time$, ByVal p_nLockAP As Long) As Long
Public Declare Function tem_writetimercard_sdk Lib "LCRFRW_SDK.dll" (ByVal fksj$, ByVal nxh As Long, ByVal time$, ByVal p_nLockAP As Long) As Long
Public Declare Function tem_readidcard_sdk Lib "LCRFRW_SDK.dll" (ByVal idbuff$) As Long
Public Declare Function tem_readdatetime_sdk Lib "LCRFRW_SDK.dll" (ByVal p_csStartTime$, ByVal p_nUnit$, ByVal p_nTimes$, ByVal p_nLockAP As Long) As Long
Option Explicit
Dim nCom As Long
Dim MsTable(2 * 1024) As String
Dim nCount As Long
Dim pubBh As String
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Sub Command1_Click()
'On Error Resume Next
Dim nerr As Long
Dim bh1bit As String
Dim bh2bit As String
Dim bh3bit As String
Dim bh4bit As String
Dim strBh As String
nCom = Val(Text1.Text)
If nCom < 0 Or nCom > 255 Then
Text1.Text = 0
nCom = 0
End If
Call mif_closecom
'打开串口
nerr = mif_selecom(nCom, 9600)
Dim buf1 As String * 20
Dim buf2 As String * 20
Dim l_nLockAP As Long
Dim l_csSDT As String * 8
Dim l_csUnit As String * 8
Dim l_csTimes As String * 8
If nerr <> 0 Then
'关闭串口
Call mif_closecom
MsgBox "初始化串口错误!", vbOKOnly + vbInformation
Exit Sub
End If
l_nLockAP = Int(Val(txtLockAP.Text))
If l_nLockAP > 255 Then
l_nLockAP = 0
End If
'开始读数据
nerr = tem_readdoorcard_sdk(buf1, buf2, l_nLockAP)
If nerr <> 0 Then
'关闭串口
Call mif_closecom
MsgBox "读卡错误!(" & Str(nerr) & ")", vbOKOnly + vbInformation
Exit Sub
End If
'开始读卡起始结束时间
nerr = tem_readdatetime_sdk(l_csSDT, l_csUnit, l_csTimes, l_nLockAP)
If nerr <> 0 Then
'关闭串口
Call mif_closecom
MsgBox "读卡错误!(" & Str(nerr) & ")", vbOKOnly + vbInformation
Exit Sub
End If
strBh = Mid(buf1, 1, 10)
Text2.Text = strBh
Text11.Text = strBh
Text9.Text = strBh
Text3.Text = buf2
Dim l_csCOTime As String
Dim l_csSDT_All As String
Dim l_csEDT_All As String
l_csCOTime = "12"
l_csSDT_All = "20" & Mid(l_csSDT, 1, 2) & "-" & Mid(l_csSDT, 3, 2) & "-" & Mid(l_csSDT, 5, 2) & " " & Mid(l_csSDT, 7, 2)
l_csEDT_All = "20" & Mid(l_csSDT, 1, 2) & "-" & Mid(l_csSDT, 3, 2) & "-" & Mid(l_csSDT, 5, 2) & " " & l_csCOTime
l_csSDT_All = l_csSDT_All + ":00:00"
l_csEDT_All = l_csEDT_All + ":00:00"
If IsDate(l_csSDT_All) And IsDate(l_csEDT_All) Then
Select Case Val(l_csUnit)
Case 0 '以时为单位
l_csEDT_All = CDate(l_csSDT_All) + Val(l_csTimes) / 24
Case 1 '以日为单位
l_csEDT_All = CDate(l_csEDT_All) + Val(l_csTimes)
Case 2 '以月为单位
l_csEDT_All = CDate(l_csEDT_All) + Val(l_csTimes) * 30
Case 3 '以年为单位
l_csEDT_All = CDate(l_csEDT_All) + Val(l_csTimes) * 365
Case Else '无效的时间单位
l_csEDT_All = "无效"
End Select
End If
txtSDT.Text = l_csSDT_All
txtEDT.Text = l_csEDT_All
pubBh = Text2.Text
'关闭串口
Call mif_closecom
MsgBox "读卡成功!", vbOKOnly + vbInformation
End Sub
Private Sub Command10_Click()
On Error Resume Next
Dim nerr As Long
nCom = Val(Text1.Text)
If nCom < 0 Or nCom > 255 Then
Text1.Text = 0
nCom = 0
End If
Call mif_closecom
'打开串口
nerr = mif_selecom(nCom, 9600)
Dim buf1 As String * 10
'开始读ID卡卡号
nerr = tem_readidcard_sdk(buf1$)
If nerr <> 0 Then
'关闭串口
txtIDCardNo.Text = ""
Call mif_closecom
MsgBox "读卡错误!(" & Str(nerr) & ")", vbOKOnly + vbInformation
Exit Sub
End If
txtIDCardNo.Text = buf1
'关闭串口
Call mif_closecom
MsgBox "读卡成功!", vbOKOnly + vbInformation
End Sub
Private Sub Command2_Click()
On Error Resume Next
Dim nerr As Long
nCom = Val(Text1.Text)
If nCom < 0 Or nCom > 255 Then
Text1.Text = 0
nCom = 0
End If
Call mif_closecom
'打开串口
nerr = mif_selecom(nCom, 9600)
Dim buf1 As String * 4
Dim buf2 As String * 10
If nerr <> 0 Then
'关闭串口
Call mif_closecom
MsgBox "初始化串口错误!", vbOKOnly + vbInformation
Exit Sub
End If
Dim bh1bit As String
Dim bh2bit As String
Dim bh3bit As String
Dim bh4bit As String
Dim l_nLockAP As Long
Dim strBh As String
strBh = Trim(Text9.Text)
If Len(strBh) <> 10 Then
Call mif_closecom
MsgBox "门锁编号的长度不足10位!", vbOKOnly + vbInformation
Exit Sub
End If
bh1bit = ChrB(Val("&H" & Mid(strBh, 1, 2)))
bh2bit = ChrB(Val("&H" & Mid(strBh, 3, 2)))
bh3bit = ChrB(Val("&H" & Mid(strBh, 5, 2)))
bh4bit = ChrB(Val("&H" & Mid(strBh, 7, 2)))
strBh = Text9.Text
buf1 = Text9.Text
buf2 = Text8.Text
l_nLockAP = Val(txtLockAP.Text)
If l_nLockAP > 255 Then
l_nLockAP = 0
End If
'开始写数据
nerr = tem_writedoorcard_sdk(strBh$, buf2$, Val(Text4.Text), Val(Text5.Text), Val(Text6.Text), Check1.Value, l_nLockAP)
If nerr <> 0 Then
'关闭串口
Call mif_closecom
MsgBox "写卡错误!(" & Str(nerr) & ")", vbOKOnly + vbInformation
Exit Sub
End If
'关闭串口
Call mif_closecom
MsgBox "写卡成功!", vbOKOnly + vbInformation
End Sub
Private Sub Command3_Click()
End
End Sub
Private Sub Command4_Click()
If Text2.Text = "" Or Text10.Text = "" Then
MsgBox "无门锁编号或房号名称!", vbOKOnly + vbInformation
Exit Sub
End If
Dim curStr As String
Dim strCount As String
Dim i As Long
Dim curBh As String * 10
curBh = Text11.Text
curStr = curBh & vbTab & Text10.Text
For i = 0 To nCount - 1
If MsTable(i) = curStr Then
Exit Sub
End If
Next
nCount = nCount + 1
strCount = Str(nCount)
MsTable(nCount - 1) = curStr
Open App.Path & "\BhFh.txt" For Output As #1
Print #1, strCount
For i = 0 To nCount - 1
Print #1, MsTable(i)
Next
Close #1
Call OpenMsTabeFile
' MsgBox "保存完成!", vbOKOnly + vbInformation
End Sub
Private Sub Command5_Click()
If MsgBox("确实全部清除吗?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
CopyFile App.Path & "\bhfh.txt", App.Path & "\bhfh" + Format(Now, "mmddHHMMSS") + ".txt", False
Open App.Path & "\BhFh.txt" For Output As #1
Print #1, 0
Close #1
Call OpenMsTabeFile
End Sub
Private Sub Command6_Click()
Dim curStr As String
Dim strCount As String
Dim i As Long
If List1.ListIndex = -1 Then Exit Sub
If MsgBox("确实清除当前内容吗?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
List1.RemoveItem List1.ListIndex
For i = 0 To List1.ListCount - 1
MsTable(i) = List1.List(i)
Next
nCount = List1.ListCount
strCount = Str(nCount)
Open App.Path & "\BhFh.txt" For Output As #1
Print #1, strCount
For i = 0 To nCount - 1
Print #1, MsTable(i)
Next
Close #1
Call OpenMsTabeFile
End Sub
Private Sub Command7_Click()
Dim id As Long
id = Shell("notepad.exe " + App.Path + "\BhFh.txt", vbNormalFocus)
End Sub
Private Sub Command8_Click()
'On Error Resume Next
Dim nerr As Long
Dim bh1bit As String
Dim bh2bit As String
Dim bh3bit As String
Dim bh4bit As String
Dim strFksj As String
Dim strTime As String
Dim buf1 As String * 10
Dim buf2 As String * 10
Dim l_nLockAP As Long
nCom = Val(Text1.Text)
If nCom < 0 Or nCom > 255 Then
Text1.Text = 0
nCom = 0
End If
Call mif_closecom
'打开串口
nerr = mif_selecom(nCom, 9600)
If nerr <> 0 Then
'关闭串口
Call mif_closecom
MsgBox "初始化串口错误!", vbOKOnly + vbInformation
Exit Sub
End If
l_nLockAP = Int(Val(txtLockAP.Text))
If l_nLockAP > 255 Then
l_nLockAP = 0
End If
'开始读数据
nerr = tem_readtimercard_sdk(buf1, buf2, l_nLockAP)
If nerr <> 0 Then
'关闭串口
Call mif_closecom
MsgBox "读卡错误!(" & Str(nerr) & ")", vbOKOnly + vbInformation
Exit Sub
End If
'关闭串口
Call mif_closecom
MsgBox "读卡成功!", vbOKOnly + vbInformation
End Sub
Private Sub Command9_Click()
'On Error Resume Next
Dim nerr As Long
Dim bh1bit As String
Dim bh2bit As String
Dim bh3bit As String
Dim bh4bit As String
Dim nxh As Long
Dim strFksj As String
Dim strTime As String
Dim l_nLockAP As Long
nCom = Val(Text1.Text)
If nCom < 0 Or nCom > 255 Then
Text1.Text = 0
nCom = 0
End If
Call mif_closecom
'打开串口
nerr = mif_selecom(nCom, 9600)
If nerr <> 0 Then
'关闭串口
Call mif_closecom
MsgBox "初始化串口错误!", vbOKOnly + vbInformation
Exit Sub
End If
l_nLockAP = Int(Val(txtLockAP.Text))
If l_nLockAP > 255 Then
l_nLockAP = 0
End If
'开始读数据
nerr = tem_writetimercard_sdk(buf1, nxh, buf2, l_nLockAP)
If nerr <> 0 Then
'关闭串口
Call mif_closecom
MsgBox "写卡错误!(" & Str(nerr) & ")", vbOKOnly + vbInformation
Exit Sub
End If
'关闭串口
Call mif_closecom
MsgBox "写卡成功!", vbOKOnly + vbInformation
End Sub
Private Sub Form_Load()
Dim curStr As String
Dim i As Long
Text8.Text = Right(Year(Date), 2) + Format(Month(Date), "00") + Format(Day(Date), "00") + Format(Hour(time), "00")
Call OpenMsTabeFile
End Sub
Private Sub OpenMsTabeFile()
Dim i As Long
Dim curStr As String
Dim curTotalStr As String
Dim strCount As String
List1.Clear
If Dir$(App.Path & "\BhFh.txt") <> "" Then
Open App.Path & "\BhFh.txt" For Input As #1
Input #1, strCount
nCount = strCount
For i = 0 To nCount - 1
Input #1, curStr
MsTable(i) = curStr
List1.AddItem curStr
Next
Close #1
End If
End Sub