readernet.frm

TCP/IP考勤读卡器的VB例程

      EndProperty
      Height          =   255
      Left            =   240
      TabIndex        =   10
      Top             =   360
      Width           =   1455
   End
End
Attribute VB_Name = "readernet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'定义发送和接收的数据包计数器
Dim SendPack, RecePack As Integer
'定义暂存的设置内容
Dim OldLocalIp, OldRemoteIp, OldGateIp, OldMask As String
Dim TempArray(32) As Byte

'单字节二进制转换为字符串类型
Private Function ByteToStr(Data As Byte, Stype As Integer, Sdec As Boolean) As String
    'Stype选择转换的类型,2为二进制输出,10为十进制输出,16为十六进制输出
    'Sdec为Ture时去掉输出字符串前的零
    Dim OutStr As String
    Dim arrdata(8) As Integer
    Dim i As Integer
'十进制转换
    If Stype = 10 Then
        arrdata(0) = Data \ 100 + 48
        arrdata(1) = (Data Mod 100) \ 10 + 48
        arrdata(2) = (Data Mod 10) + 48
        If Sdec = flase Then
            OutStr = Chr(arrdata(0)) + Chr(arrdata(1)) + Chr(arrdata(2))
        Else
            If arrdata(0) = 48 And arrdata(1) = 48 Then
                OutStr = Chr(arrdata(2))
            ElseIf arrdata(0) = 48 Then
                OutStr = Chr(arrdata(1)) + Chr(arrdata(2))
            Else
                OutStr = Chr(arrdata(0)) + Chr(arrdata(1)) + Chr(arrdata(2))
            End If
        End If
'十六进制转换
    ElseIf Stype = 16 Then
        arrdata(0) = Data \ 16 + 48
        If arrdata(0) > 57 Then arrdata(0) = arrdata(0) + 7
        arrdata(1) = (Data Mod 16) + 48
        If arrdata(1) > 57 Then arrdata(1) = arrdata(1) + 7
        If Sdec = flase Then
            OutStr = Chr(arrdata(0)) + Chr(arrdata(1))
        Else
            If arrdata(0) = 48 Then
                OutStr = Chr(arrdata(1))
            Else
                OutStr = Chr(arrdata(0)) + Chr(arrdata(1))
            End If
        End If
'二进制转换
    ElseIf Stype = 2 Then
    
    End If
    ByteToStr = OutStr
End Function
'整数转换为字符串类型
Private Function IntToStr(Data As Integer, Stype As Integer, Sdec As Boolean) As String
    'Stype选择转换的类型,2为二进制输出,10为十进制输出,16为十六进制输出
    'Sdec为Ture时去掉输出字符串前的零
    Dim OutStr As String
    Dim arrdata(16) As Integer
    Dim i As Integer
    If Stype = 10 Then
        arrdata(0) = Data \ 10000 + 48
        arrdata(1) = (Data Mod 10000) \ 1000 + 48
        arrdata(2) = (Data Mod 1000) \ 100 + 48
        arrdata(3) = (Data Mod 100) \ 10 + 48
        arrdata(4) = (Data Mod 10) + 48
        If Sdec = flase Then
            OutStr = Chr(arrdata(0)) + Chr(arrdata(1)) + Chr(arrdata(2)) + Chr(arrdata(3)) + Chr(arrdata(4))
        Else
            If arrdata(0) <> 48 Then
                OutStr = Chr(arrdata(0)) + Chr(arrdata(1)) + Chr(arrdata(2)) + Chr(arrdata(3)) + Chr(arrdata(4))
            ElseIf arrdata(1) <> 48 Then
                OutStr = Chr(arrdata(1)) + Chr(arrdata(2)) + Chr(arrdata(3)) + Chr(arrdata(4))
            ElseIf arrdata(2) <> 48 Then
                OutStr = Chr(arrdata(2)) + Chr(arrdata(3)) + Chr(arrdata(4))
            ElseIf arrdata(3) <> 48 Then
                OutStr = Chr(arrdata(3)) + Chr(arrdata(4))
            Else
                OutStr = Chr(arrdata(4))
            End If
        End If
    ElseIf Stype = 16 Then
        arrdata(0) = Data \ 4096 + 48
        If arrdata(0) > 57 Then arrdata(0) = arrdata(0) + 7
        arrdata(1) = (Data Mod 4096) \ 256 + 48
        If arrdata(1) > 57 Then arrdata(1) = arrdata(1) + 7
        arrdata(2) = (Data Mod 256) \ 16 + 48
        If arrdata(2) > 57 Then arrdata(2) = arrdata(2) + 7
        arrdata(3) = (Data Mod 16) + 48
        If arrdata(3) > 57 Then arrdata(3) = arrdata(3) + 7
        If Sdec = flase Then
            OutStr = Chr(arrdata(0)) + Chr(arrdata(1)) + Chr(arrdata(2)) + Chr(arrdata(3))
        Else
            If arrdata(0) <> 48 Then
                OutStr = Chr(arrdata(0)) + Chr(arrdata(1)) + Chr(arrdata(2)) + Chr(arrdata(3))
            ElseIf arrdata(1) <> 48 Then
                OutStr = Chr(arrdata(1)) + Chr(arrdata(2)) + Chr(arrdata(3))
            ElseIf arrdata(2) <> 48 Then
                OutStr = Chr(arrdata(2)) + Chr(arrdata(3))
            Else
                OutStr = Chr(arrdata(3))
            End If
        End If
    ElseIf Stype = 2 Then
    
    End If
    IntToStr = OutStr
End Function
'将IP地址型字符串转换为4个字节型
Private Function StrToByte(s As String)
Dim i, n, j As Integer
Dim c As Byte
i = 1
For n = 0 To 3
    c = Asc(Mid(s, i, 1)) - 48
    i = i + 1
    j = c
    If i <= Len(s) Then
        c = Asc(Mid(s, i, 1))
        i = i + 1
        If c <> 46 Then
            j = j * 10 + c - 48
            If i <= Len(s) Then
                c = Asc(Mid(s, i, 1))
                i = i + 1
                If c <> 46 Then
                    j = j * 10 + c - 48
                    i = i + 1
                    TempArray(n) = j
                Else
                    TempArray(n) = j
                End If
            Else
                TempArray(n) = j
            End If
        Else
            TempArray(n) = j
        End If
    Else
        TempArray(n) = j
    End If
Next n
End Function
Private Sub BeepCheck_Click()
Dim OutStr(17) As Byte
Dim i As Integer
If ReaderIDText.Text <> "" Then
'发送数据头
    OutStr(0) = 25
    OutStr(1) = 118
    OutStr(2) = 5
    OutStr(3) = 6
    OutStr(4) = 86
'发送的读卡器号
    For i = 1 To 12
        OutStr(i + 4) = Asc(Mid(ReaderIDText.Text, i, 1))
    Next i
    If LEDCheck.Value = 1 Then OutStr(17) = 128
    If BeepCheck.Value = 1 Then OutStr(17) = OutStr(17) + 64
    i = 1
    With Winsock1
        While Mid(.LocalIP, i, 1) <> "."
            i = i + 1
        Wend
        i = i + 1
        While Mid(.LocalIP, i, 1) <> "."
            i = i + 1
        Wend
        i = i + 1
        While Mid(.LocalIP, i, 1) <> "."
            i = i + 1
        Wend
        s = Left(.LocalIP, i)
        s = s + "255"
        .RemoteHost = s
        .RemotePort = 3002
    End With
'发送数据
    Winsock1.SendData OutStr
'发送的数据包计数器增一
    SendPack = SendPack + 1
    Label7.Caption = Str(SendPack)
End If
End Sub

Private Sub ExitCommand_Click()
    End
End Sub

Private Sub Form_Load()
    Dim clmX As ColumnHeader
    Dim s As String
    Dim i As Integer
    '初始化Winsock控件
    '取得广播地址
    i = 1
    With Winsock1
        While Mid(.LocalIP, i, 1) <> "."
            i = i + 1
        Wend
        i = i + 1
        While Mid(.LocalIP, i, 1) <> "."
            i = i + 1
        Wend
        i = i + 1
        While Mid(.LocalIP, i, 1) <> "."
            i = i + 1
        Wend
        s = Left(.LocalIP, i)
        s = s + "255"
        .Protocol = sckUDPProtocol
        .RemoteHost = s
        .RemotePort = 3002
        .Bind 3003
    End With
    SendPack = 0
    RecePack = 0
    OldLocalIp = ""
    '为 ColumnHeader 对象创建对象变量。
   '添加 ColumnHeaders。列宽度等于控件宽度
   '除以 ColumnHeader 对象的数目。
    With InfList
        Set clmX = .ColumnHeaders.Add(, , "读卡器编号", .Width / 4)
        Set clmX = .ColumnHeaders.Add(, , "IP地址", .Width / 3)
        Set clmX = .ColumnHeaders.Add(, , "物理地址", .Width * 2 / 5)
        Set clmX = .ColumnHeaders.Add(, , "服务器IP地址", .Width / 3)
        Set clmX = .ColumnHeaders.Add(, , "网关IP地址", .Width / 3)
        Set clmX = .ColumnHeaders.Add(, , "子网掩码", .Width / 3)
        Set clmX = .ColumnHeaders.Add(, , "读卡器端口", .Width / 5)
        Set clmX = .ColumnHeaders.Add(, , "服务器端口", .Width / 5)
        .BorderStyle = ccFixedSingle '设置 BorderStyle 属性。
        .View = lvwReport '设置 View 属性为报表型。
    End With
End Sub

Private Sub GateIpText_Change()
Dim i, j, n, m, l As Integer
Dim Char As Byte
Dim TempStr As String
j = 0
l = 0
m = GateIpText.SelStart
n = Len(GateIpText.Text)
For i = 1 To n
    Char = Asc(Mid(GateIpText.Text, i, 1))
    If Char < 48 Or Char > 57 Then
        If Char = 46 Then
            TempStr = TempStr + Chr(Char)
            j = 0
            l = 0
        End If
    Else
        j = j + 1
        If j = 4 Then
            If i < n Then
                If Asc(Mid(GateIpText.Text, i + 1, 1)) <> 46 Then
                    m = m + 1
                    TempStr = TempStr + "."
                    j = 0
                    l = 0
                End If
            Else
                m = m + 1
                TempStr = TempStr + "."
                j = 0
                l = 0
            End If
        Else
            l = l * 10 + Char - 48
            If l > 255 Then
                m = m + 1
                TempStr = TempStr + "."
                j = 0
                l = 0
            End If
        End If
        TempStr = TempStr + Chr(Char)
    End If
Next i
n = Len(TempStr)
j = 0
l = 0
For i = 1 To n
    Char = Asc(Mid(TempStr, i, 1))
    If Char > 47 And Char < 58 Then
        l = l * 10 + Char - 48
        If l > 255 Then
            j = 4
        End If
    End If
    If Char = 46 Then
        j = j + 1
        l = 0
    End If
Next i
If j > 3 Then TempStr = OldGateIp
GateIpText.Text = TempStr
GateIpText.SelStart = m
OldGateIp = GateIpText.Text

End Sub

Private Sub InfList_ItemClick(ByVal Item As MSComctlLib.ListItem)
'将列表中的数据显示到文本框中
    ReaderIDText.Text = InfList.ListItems(Item.Index)
    LocalIpText.Text = InfList.ListItems(Item.Index).ListSubItems(1)
    RemoteIpText.Text = InfList.ListItems(Item.Index).ListSubItems(3)
    GateIpText.Text = InfList.ListItems(Item.Index).ListSubItems(4)
    MaskText.Text = InfList.ListItems(Item.Index).ListSubItems(5)
End Sub

Private Sub LEDCheck_Click()
Dim OutStr(17) As Byte
Dim i As Integer
If ReaderIDText.Text <> "" Then
'发送控制命令
    OutStr(0) = 25
    OutStr(1) = 118
    OutStr(2) = 5
    OutStr(3) = 6
    OutStr(4) = 86
    For i = 1 To 12
        OutStr(i + 4) = Asc(Mid(ReaderIDText.Text, i, 1))
    Next i
    If LEDCheck.Value = 1 Then OutStr(17) = 128
    If BeepCheck.Value = 1 Then OutStr(17) = OutStr(17) + 64
    i = 1
    With Winsock1
        While Mid(.LocalIP, i, 1) <> "."
            i = i + 1
        Wend
        i = i + 1
        While Mid(.LocalIP, i, 1) <> "."
            i = i + 1
        Wend
        i = i + 1
        While Mid(.LocalIP, i, 1) <> "."
            i = i + 1
        Wend
        s = Left(.LocalIP, i)
        s = s + "255"
        .RemoteHost = s
        .RemotePort = 3002
    End With
    Winsock1.SendData OutStr
'发送的数据包计数器增一
    SendPack = SendPack + 1
    Label7.Caption = Str(SendPack)
End If
End Sub