Private Sub BtExit_Click()
If Timer1.Enabled Then
Timer1.Enabled = False
\'CloseComm
End If
End
End Sub
Private Sub BtReadNewAddr_Click()
Dim sData As String
Dim byData(256) As Byte
Dim FileName As String
\'nRet = Read_Content(3)
If nRet = 1 Then
\'
FileName = App.Path & "\\NewAddr.txt"
Open FileName For Binary Access Read Shared As FileNumber
Get FileNumber, 1, byData
sData = byData
Trim sData
sLnewaddr.Caption = sData
Else
txtMsg.Caption = "读追加信息失败"
End If
End Sub
Private Sub Command1_Click()
Dim FileName As String
Dim FileNumber As Integer
Dim FileLength As Long
Dim sData As String
Dim sName As String
Dim byData(256) As Byte
Dim sSex As String
Dim sFolk As String
Dim sBirth As String
Dim sAddr As String
Dim sID As String
Dim sIssue As String
Dim sBegin As String
Dim sEnd As String
On Error GoTo FileContainsError
FileName = App.Path & "\\wz.txt" \' "E:\\VB\\wz.txt" \'调试时指定路径,因为VB调试是工作路径不是程序路径
FileNumber = FreeFile
Open FileName For Binary Access Read Shared As FileNumber
FileLength = LOF(FileNumber)
If FileLength = 256 Then
Get FileNumber, 1, byData
sData = byData
FileLength = Len(sData)
sName = Mid$(sData, 1, 15)
Trim (sName)
MsgBox sName, vbOKOnly, "Info", 0, 0
sSex = Mid$(sData, 16, 1)
MsgBox sSex, vbOKOnly, "Info", 0, 0
sFolk = Mid$(sData, 17, 2)
MsgBox sFolk, vbOKOnly, "Info", 0, 0
sBirth = Mid$(sData, 19, 8)
MsgBox sBirth, vbOKOnly, "Info", 0, 0
sAddr = Mid$(sData, 27, 35)
MsgBox sAddr, vbOKOnly, "Info", 0, 0
sID = Mid$(sData, 62, 18)
MsgBox sID, vbOKOnly, "Info", 0, 0
sIssue = Mid$(sData, 80, 15)
MsgBox sIssue, vbOKOnly, "Info", 0, 0
sBegin = Mid$(sData, 95, 8)
MsgBox sBegin, vbOKOnly, "Info", 0, 0
sEnd = Mid$(sData, 103, 8)
MsgBox sEnd, vbOKOnly, "Info", 0, 0
End If
Close FileNumber
Exit Sub
FileContainsError:
Select Case Err
Case Else
MsgBox Error$ & " on file " & FileName
End Select
Exit Sub
End Sub
Private Sub Form_Load()
\'Exit Sub
sLname.Caption = ""
sLsex.Caption = ""
sLfolk.Caption = ""
sLbirth.Caption = ""
sLAddr.Caption = ""
sLissue.Caption = ""
sLID.Caption = ""
sLindate.Caption = ""
sLnewaddr.Caption = ""
Dim cmd As Byte
Dim para0 As Long
Dim para1 As Long
Dim para2 As Long
Picture1.Picture = LoadPicture(App.Path & "\\blank.bmp")
Dim i As Long
bRun = False \'初始化定时器变量
cmd = 65 \'0x41
para0 = 0
para1 = 8811
para2 = 9986
nRet = UCommand1(cmd, para0, para1, para2)
If nRet = 62171 Then
Timer1.Enabled = True
txtMsg.Caption = nRet
txtMsg.Caption = txtMsg.Caption + "连接机具成功"
Else
Timer1.Enabled = False
txtMsg.Caption = nRet
txtMsg.Caption = txtMsg.Caption + "连接机具失败"
End If
End Sub
Private Sub Timer1_Timer()
Dim cmd As Byte
Dim para0 As Long
Dim para1 As Long
Dim para2 As Long
Dim FileName As String
Dim FileNumber As Integer
Dim FileLength As Long
Dim sData As String
Dim sName As String
Dim byData(256) As Byte
Dim sSex As String
Dim sFolk As String
Dim sBirth As String
Dim sAddr As String
Dim sID As String
Dim sIssue As String
Dim sBegin As String
Dim sEnd As String \'
If Not bRun Then
bRun = True
\'========================================================
txtMsg.Caption = "请放卡..."
cmd = 67 \'0x43
para0 = 0
para1 = 8811
para2 = 9986
nRet = UCommand1(cmd, para0, para1, para2) \'验证卡
If nRet = 62171 Then
txtMsg.Caption = "正在读卡..."
\'--------------------------------------------
sLname.Caption = ""
sLsex.Caption = ""
sLfolk.Caption = ""
sLbirth.Caption = ""
sLAddr.Caption = ""
sLissue.Caption = ""
sLID.Caption = ""
sLindate.Caption = ""
sLnewaddr.Caption = ""
Picture1.Picture = LoadPicture(App.Path & "\\blank.bmp")
\'--------------------------------------------
cmd = 68 \'0x44 读卡内信息
para0 = 0
para1 = 8811
para2 = 9986
nRet = UCommand1(cmd, para0, para1, para2) \'读卡内信息
If nRet = 62171 Then
\'On Error GoTo FileContainsError
FileName = App.Path & "\\wz.txt" \' "E:\\VB\\wz.txt" \'调试时指定路径,因为VB调试是工作路径不是程序路径
FileNumber = FreeFile
Open FileName For Binary Access Read Shared As FileNumber
FileLength = LOF(FileNumber)
If FileLength = 256 Then
Get FileNumber, 1, byData
sData = byData
sName = Mid$(sData, 1, 15)
Trim (sName)
sLname.Caption = sName
\'MsgBox sName, vbOKOnly, "Info", 0, 0
sSex = Mid$(sData, 16, 1)
Trim (sSex)
If sSex = "1" Then
sLsex.Caption = "男"
ElseIf sSex = "2" Then
sLsex.Caption = "女"
Else
sLsex.Caption = "非法"
End If
\'MsgBox sSex, vbOKOnly, "Info", 0, 0
sFolk = Mid$(sData, 17, 2)
Trim (sFolk)
sLfolk.Caption = GetFolk(sFolk)
\'MsgBox sFolk, vbOKOnly, "Info", 0, 0
sBirth = Mid$(sData, 19, 8)
Trim (sBirth)
sLbirth.Caption = Mid$(sBirth, 1, 4) + "年" + Mid$(sBirth, 5, 2) + "月" + Mid$(sBirth, 7, 2) + "日"
\'MsgBox sBirth, vbOKOnly, "Info", 0, 0
sAddr = Mid$(sData, 27, 35)
Trim (sAddr)
sLAddr.Caption = sAddr
\'MsgBox sAddr, vbOKOnly, "Info", 0, 0
sID = Mid$(sData, 62, 18)
Trim (sID)
sLID.Caption = sID
\'MsgBox sID, vbOKOnly, "Info", 0, 0
sIssue = Mid$(sData, 80, 15)
Trim (sIssue)
sLissue.Caption = sIssue
\'MsgBox sIssue, vbOKOnly, "Info", 0, 0
sBegin = Mid$(sData, 95, 8)
Trim (sBegin)
\'MsgBox sBegin, vbOKOnly, "Info", 0, 0
sEnd = Mid$(sData, 103, 8)
Trim (sEnd)
\'MsgBox sEnd, vbOKOnly, "Info", 0, 0
sLindate.Caption = sBegin + "-" + sEnd
Picture1.Picture = LoadPicture(App.Path & "\\zp.bmp")
End If
Close FileNumber
ElseIf nRet = -5 Then
MsgBox "软件未授权!", vbOKOnly, "提示信息", 0, 0
End If
End If
\'========================================================
bRun = False
End If
End Sub
代码二:
Option Explicit
\' =========================================================
\' Class: cIniFile
\' Author: Steve McMahon
\' Date : 21 Feb 1997
\'
\' A nice class wrapper around the INIFile functions
\' Allows searching,deletion,modification and addition
\' of Keys or Values.
\'
\' Updated 10 May 1998 for VB5.
\' * Added EnumerateAllSections method
\' * Added Load and Save form position methods
\' =========================================================
Private m_sPath As String
Private m_sKey As String
Private m_sSection As String
Private m_sDefault As String
Private m_lLastReturnCode As Long
#If Win32 Then
\' Profile String functions:
Private Declare Function WritePrivateProfileString Lib "KERNEL32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "KERNEL32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As Any, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
#Else
\' Profile String functions:
Private Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Integer
Private Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
#End If
Property Get LastReturnCode() As Long
LastReturnCode = m_lLastReturnCode
End Property
Property Get Success() As Boolean
Success = (m_lLastReturnCode <> 0)
End Property
Property Let Default(sDefault As String)
m_sDefault = sDefault
End Property
Property Get Default() As String
Default = m_sDefault
End Property
Property Let Path(sPath As String)
m_sPath = sPath
End Property
Property Get Path() As String
Path = m_sPath
End Property
Property Let Key(sKey As String)
m_sKey = sKey
End Property
Property Get Key() As String
Key = m_sKey
End Property
Property Let Section(sSection As String)
m_sSection = sSection
End Property
Property Get Section() As String
Section = m_sSection
End Property
Property Get Value() As String
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(255)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(m_sSection, m_sKey, m_sDefault, sBuf, iSize, m_sPath)
If (iSize > 0) Then
Value = Left$(sBuf, iRetCode)
m_lLastReturnCode = 1
Else
Value = ""
End If
End Property
Property Let Value(sValue As String)
Dim iPos As Integer
\' Strip chr$(0):
iPos = InStr(sValue, Chr$(0))
Do While iPos <> 0
sValue = Left$(sValue, (iPos - 1)) & Mid$(sValue, (iPos + 1))
iPos = InStr(sValue, Chr$(0))
Loop
m_lLastReturnCode = WritePrivateProfileString(m_sSection, m_sKey, sValue, m_sPath)
End Property
Public Sub DeleteKey()
m_lLastReturnCode = WritePrivateProfileString(m_sSection, m_sKey, 0&, m_sPath)
End Sub
Public Sub DeleteSection()
m_lLastReturnCode = WritePrivateProfileString(m_sSection, 0&, 0&, m_sPath)
End Sub
Property Get INISection() As String
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(8192)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(m_sSection, 0&, m_sDefault, sBuf, iSize, m_sPath)
If (iSize > 0) Then
INISection = Left$(sBuf, iRetCode)
Else
INISection = ""
End If
End Property
Property Let INISection(sSection As String)
m_lLastReturnCode = WritePrivateProfileString(m_sSection, 0&, sSection, m_sPath)
End Property
Property Get Sections() As String
Dim sBuf As String
Dim iSize As String
Dim iRetCode As Integer
sBuf = Space$(8192)
iSize = Len(sBuf)
iRetCode = GetPrivateProfileString(0&, 0&, m_sDefault, sBuf, iSize, m_sPath)
If (iSize > 0) Then
Sections = Left$(sBuf, iRetCode)
Else
SectiMaximised"
Value = (frmThis.WindowState = vbMaximized) * -1
If (frmThis.WindowState <> vbMaximized) Then
Key = "Left"
Value = frmThis.Left
Key = "Top"
Value = frmThis.Top
Key = "Width"
Value = frmThis.Width
Key = "Height"
Value = frmThis.Height
End If
End If
Key = sSaveKey
Exit Sub
SaveError:
Key = sSaveKey
m_lLastReturnCode = 0
Exit Sub
End Sub
Public Sub LoadFormPosition(ByRef frmThis As Object, Optional ByRef lMinWidth = 3000, Optional ByRef lMinHeight = 3000)
Dim sSaveKey As String
Dim sSaveDefault As String
Dim lLeft As Long
Dim lTOp As Long
Dim lWidth As Long
Dim lHeight As Long
On Error GoTo LoadError
sSaveKey = Key
sSaveDefault = Default
Default = "FAIL"
Key = "Left"
lLeft = CLngDefault(Value, frmThis.Left)
Key = "Top"
lTOp = CLngDefault(Value, frmThis.Top)
Key = "Width"
lWidth = CLngDefault(Value, frmThis.Width)
If (lWidth < lMinWidth) Then lWidth = lMinWidth
Key = "Height"
lHeight = CLngDefault(Value, frmThis.Height)
If (lHeight < lMinHeight) Then lHeight = lMinHeight
If (lLeft < 4 * Screen.TwipsPerPixelX) Then lLeft = 4 * Screen.TwipsPerPixelX
If (lTOp < 4 * Screen.TwipsPerPixelY) Then lTOp = 4 * Screen.TwipsPerPixelY
If (lLeft + lWidth > Screen.Width - 4 * Screen.TwipsPerPixelX) Then
lLeft = Screen.Width - 4 * Screen.TwipsPerPixelX - lWidth
If (lLeft < 4 * Screen.TwipsPerPixelX) Then lLeft = 4 * Screen.TwipsPerPixelX
If (lLeft + lWidth > Screen.Width - 4 * Screen.TwipsPerPixelX) Then
lWidth = Screen.Width - lLeft - 4 * Screen.TwipsPerPixelX
End If
End If
If (lTOp + lHeight > Screen.Height - 4 * Screen.TwipsPerPixelY) Then
lTOp = Screen.Height - 4 * Screen.TwipsPerPixelY - lHeight
If (lTOp < 4 * Screen.TwipsPerPixelY) Then lTOp = 4 * Screen.TwipsPerPixelY
If (lTOp + lHeight > Screen.Height - 4 * Screen.TwipsPerPixelY) Then
lHeight = Screen.Height - lTOp - 4 * Screen.TwipsPerPixelY
End If
End If
If (lWidth >= lMinWidth) And (lHeight >= lMinHeight) Then
frmThis.Move lLeft, lTOp, lWidth, lHeight
End If
Key = "Maximised"
If (CLngDefault(Value, 0) <> 0) Then
frmThis.WindowState = vbMaximized
End If
Key = sSaveKey
Default = sSaveDefault
Exit Sub
LoadError:
Key = sSaveKey
Default = sSaveDefault
m_lLastReturnCode = 0
Exit Sub
End Sub
Public Function CLngDefault(ByVal sString As String, Optional ByVal lDefault As Long = 0) As Long
Dim lR As Long
On Error Resume Next
lR = CLng(sString)
If (Err.Number <> 0) Then
CLngDefault = lDefault
Else
CLngDefault = lR
End If
End Function