frmdemo.frm

HD 6P RFID 终端机、考勤卡钟 TCP/IP通讯接口程序 VB 源码

       bTemp(11) = 0            '白名单模式
    End If
    bTemp(12) = 0          ' 上下班状态
     If chkOfflineMode.Value = 1 Then
       bTemp(13) = 1         ' 脱机模式否
    Else
       bTemp(13) = 0
    End If
    m_HD8583.LenOfAdditionalData1 = Len(bTemp(0)) * 14
    Call CopyMemory(m_HD8583.AdditionalData1(0), bTemp(0), m_HD8583.LenOfAdditionalData1)

    m_HD8583.LenOfAdditionalData2 = 20
    Dim nTemp As Long
    nTemp = 500      ' 日消费限额
    Call CopyMemory(m_HD8583.AdditionalData2(0), nTemp, Len(nTemp))
    nTemp = 50           ' 次消费限额
    Call CopyMemory(m_HD8583.AdditionalData2(4), nTemp, Len(nTemp))
    nTemp = 10             ' 日消费限次
    Call CopyMemory(m_HD8583.AdditionalData2(8), nTemp, Len(nTemp))
    nTemp = 5           ' 定值消费机的定值额
    Call CopyMemory(m_HD8583.AdditionalData2(12), nTemp, Len(nTemp))
    nTemp = 100        ' 透支额
    Call CopyMemory(m_HD8583.AdditionalData2(16), nTemp, Len(nTemp))
    Dim str As String * 16
    str = "东莞建邦" + " " + " 欢迎光临  "
    m_HD8583.LenOfAdditionalData3 = Len(str)
    m_HD8583.AdditionalData3 = str
    str = "8888888"                    ' 管理中心电话号码
    m_HD8583.LenOfAdditionalData4 = Len(str)
    m_HD8583.AdditionalData4 = str
    If TimerOn(CmdConfigPara, 300) Then
        Call DoSendDatagram(m_HD8583, -1)
    End If
    
End Sub

Private Sub Form_Load()
    m_bResult = CreateObject(0, COMMTYPE_TCP_IP, True, GB_GB) '创建对象
    If m_bResult Then
        sbStatus.Panels(2).Text = "创建对象成功"
    Else
        sbStatus.Panels(2).Text = "创建对象失败"
    End If
    
    txtLocalIP.Text = sckServer(0).LocalIP
    m_ClientNum = 0
    m_nStart = 0
    cmbSysID.ListIndex = 0
    Call cmbSysID_Click
    sbStatus.Panels(3).Text = Now
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Call DestroyObject '销毁对象
End Sub

'改变应用类型
Private Sub cmbSysID_Click()
    If cmbSysID.ListIndex = 0 Then
        m_nSystemID = HDA_SYSTEMIDOFATT1_1
        m_nBroadcastAddress = HDA_BROADCASTADDRESSOFONE + HDA_SYSTEMIDOFATT1_1
    ElseIf cmbSysID.ListIndex = 1 Then
        m_nSystemID = HDA_SYSTEMIDOFACC1_1
        m_nBroadcastAddress = HDA_BROADCASTADDRESSOFONE + HDA_SYSTEMIDOFACC1_1
    ElseIf cmbSysID.ListIndex = 2 Then
        m_nSystemID = HDA_SYSTEMIDOFPOS1_1
        m_nBroadcastAddress = HDA_BROADCASTADDRESSOFONE + HDA_SYSTEMIDOFPOS1_1
    Else
        m_nBroadcastAddress = HDA_BROADCASTADDRESSOFALL
    End If
End Sub

'启动服务
Private Sub cmdStart_Click()
    If txtLocalPort.Text = "" Then
        txtLocalPort.Text = "5001"
    End If
    
    If sckServer(0).State = sckClosed Then
        m_ClientNum = 0
        sckServer(0).LocalPort = txtLocalPort.Text
        sckServer(0).Bind txtLocalPort.Text, txtLocalIP.Text '多块网卡绑定其中一块
        sckServer(0).Listen
    Else
        sckServer(0).Close
    End If
    
    If sckServer(0).State = sckClosed Then
        cmdStart.Caption = "启动"
        frmMain.sbStatus.Panels(2).Text = "服务停止"
    Else
        cmdStart.Caption = "停止"
        frmMain.sbStatus.Panels(2).Text = "服务启动"
    End If
End Sub

'连接目标
Private Sub cmdConnect_Click()
    If txtRemotePort.Text = "" Then
        txtRemotePort.Text = "5002"
    End If
    
    If sckClient.State = sckClosed Then
        sckClient.RemoteHost = txtRemoteIP.Text
        sckClient.RemotePort = txtRemotePort.Text
        sckClient.Connect
    Else
        sckClient.Close
        cmdConnect.Caption = "连接"
        frmMain.sbStatus.Panels(2).Text = "与服务端断开成功"
    End If
End Sub

Private Sub cmdReecho_Click()
    ' 请求报文清零
    Call MemSet_HD(m_HD8583, &H0, Len(m_HD8583))
    m_HD8583.Message_Type = MT_REECHO2
    m_HD8583.TerminalSN = GetTerminalSN()
    m_HD8583.Address = GetAddress()
    
    If TimerOn(cmdReecho, 300) Then
        Call DoSendDatagram(m_HD8583, -1)
    End If
End Sub

Private Sub cmdNotice_Click()
    Dim DateTime As MYDATETIMESTRUCT

    ' 请求报文清零
    Call MemSet_HD(m_HD8583, &H0, Len(m_HD8583))
    m_HD8583.Message_Type = MT_ONLINENOTICE2
    m_HD8583.TerminalSN = GetTerminalSN()
    m_HD8583.Address = GetAddress()
    m_HD8583.DateTime = GetDateTime()
    m_HD8583.VerOfList = 0

    If TimerOn(cmdNotice, 3000) Then
        Call DoSendDatagram(m_HD8583, -1)
    End If
End Sub

'获取终端序列号
Private Function GetTerminalSN() As Long
    If chkBroadcast.Value = 0 Then
        GetTerminalSN = CLng(txtTerSN.Text)
    Else '广播通讯
        GetTerminalSN = HDA_BROADCASTSN
    End If
End Function

'获取终端地址
Private Function GetAddress() As Long
    If chkBroadcast.Value = 0 Then
        GetAddress = m_nSystemID + CLng(txtAddress.Text)
    Else '广播通讯
        GetAddress = m_nBroadcastAddress
    End If
End Function

'获取系统当前日期和时间
Private Function GetDateTime() As MYDATETIMESTRUCT
    Dim DateTime As MYDATETIMESTRUCT
    Dim LocalTime As SYSTEMTIME
    
    Call GetLocalTime(LocalTime)
    DateTime.Year = LocalTime.wYear - 2000
    DateTime.Month = LocalTime.wMonth
    DateTime.Day = LocalTime.wDay
    DateTime.Hour = LocalTime.wHour
    DateTime.Minute = LocalTime.wMinute
    DateTime.Second = LocalTime.wSecond
    DateTime.DayOfWeek = LocalTime.wDayOfWeek
    
    GetDateTime = DateTime
End Function

'启动等待响应定时器
Private Function TimerOn(cmd As CommandButton, Time As Long) As Boolean
    If frmMain.Timer2.Enabled Then
        MsgBox "前面操作未完成, 请稍候!"
        TimerOn = False
        Exit Function
    End If
    
    If sckClient.State = sckConnected Then
        frmMain.sbStatus.Panels(2).Text = "等待......"
        If Time > 0 Then '等待响应定时器启动
            frmMain.Timer2.Interval = Time
            frmMain.Timer2.Enabled = True
            m_nStart = GetTickCount()
            
            Set m_Button = cmd
            m_Button.Enabled = False
        End If
    Else
        frmMain.sbStatus.Panels(2).Text = "请先连接终端!"
        TimerOn = False
        Exit Function
    End If
    
    TimerOn = True
End Function

'停止等待响应定时器
Private Function TimerOff() As Long
    frmMain.Timer2.Enabled = False
    If TypeOf m_Button Is CommandButton Then
        m_Button.Enabled = True
    End If
    TimerOff = GetTickCount() - m_nStart '时延
End Function

Private Sub IDSETBL_Click()
     Dim Count As Long
     Call MemSet_HD(m_HD8583, &H0, Len(m_HD8583))
     m_HD8583.Message_Type = MT_UPDATEIDLIST2
     m_HD8583.Address = GetAddress()
     m_HD8583.TerminalID = GetTerminalID()
     m_HD8583.VerOfList = CurrentVersion + 10
     m_HD8583.LenOfAdditionalData3 = 1 ' 结束标志
     
     Dim SerialNum As Long
     SerialNum = 1
     m_HD8583.LenOfAdditionalData1 = Len(SerialNum)
     Call CopyMemory(m_HD8583.AdditionalData1(0), SerialNum, Len(SerialNum))
     Dim CardNO As Long
     For Count = 1 To CurrentVersion + 10 Step 1
         CardNO = Count + CurrentVersion
         Call CopyMemory(m_HD8583.AdditionalData2(Count * 4 - 4), CardNO, 4)
     Next Count
     m_HD8583.LenOfAdditionalData2 = 4 * Count - 4
     If (TimerOn(IDSETBL, 5000)) Then
         Call DoSendDatagram(m_HD8583, -1)
     End If
    
End Sub

'1秒钟定时器
Private Sub Timer1_Timer()
    sbStatus.Panels(3).Text = Now
End Sub

'等待响应超时
Private Sub Timer2_Timer()
    Timer2.Enabled = False '停止计时
    If TypeOf m_Button Is CommandButton Then
        m_Button.Enabled = True
    End If
    
    sbStatus.Panels(2).Text = "响应超时, 等待: " + CStr(Timer2.Interval) + "毫秒"
End Sub

Private Sub sckServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)
    If Index = 0 Then 'socket(0)用于监听
        m_ClientNum = m_ClientNum + 1
        Load sckServer(m_ClientNum)
        sckServer(m_ClientNum).LocalPort = txtLocalPort.Text
        sckServer(m_ClientNum).Accept requestID
        sbStatus.Panels(2).Text = "客户端: " + sckServer(m_ClientNum).RemoteHostIP + "连接服务成功!"
    End If
End Sub

Private Sub sckServer_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    sbStatus.Panels(2).Text = "错误码: " + CStr(Number)
End Sub

Private Sub sckServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    Dim bRecvData() As Byte
         
    sckServer(Index).GetData bRecvData, vbArray + vbByte '接收数据
    '获取请求报文
    m_bResult = GetHD8583(bRecvData(0), bytesTotal, m_ReqHd8583)
    If m_bResult Then
        '校验MAC值
        If IsMACValidA(m_bWK(1), bRecvData(0), bytesTotal) Then
            frmMain.sbStatus.Panels(2).Text = "MAC值正确"
            Call DoRecvDatagram(Index)
        Else
            frmMain.sbStatus.Panels(2).Text = "MAC值错误"
        End If
    End If
End Sub

Private Sub sckServer_SendComplete(Index As Integer)
    frmMain.sbStatus.Panels(2).Text = "发送报文成功"
End Sub

Private Sub sckClient_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    sbStatus.Panels(2).Text = "错误码: " + CStr(Number)
End Sub

Private Sub sckClient_Connect()
    cmdConnect.Caption = "断开"
    frmMain.sbStatus.Panels(2).Text = "与服务端连接成功"
End Sub

Private Sub sckClient_DataArrival(ByVal bytesTotal As Long)
    Dim bRecvData() As Byte
         
    sckClient.GetData bRecvData, vbArray + vbByte '接收数据
    '获取响应报文
    m_bResult = GetHD8583(bRecvData(0), bytesTotal, m_ReqHd8583)
    If m_bResult Then
        '校验MAC值
        If IsMACValidA(m_bWK(0), bRecvData(0), bytesTotal) Then
            frmMain.sbStatus.Panels(2).Text = "MAC值正确"
            Call DoRecvDatagram(-1)
        Else
            frmMain.sbStatus.Panels(2).Text = "MAC值错误"
        End If
    End If
End Sub

'发送报文处理
Private Function DoSendDatagram(ByRef HD8583 As HD8583STRUCT, ByVal Index As Integer) As Boolean
    m_BufferLength = Len(m_Buffer)
    m_bResult = SendHD8583(HD8583, m_Buffer, m_BufferLength, True, False) ' 转换报文
    If m_bResult Then
        ReDim m_bSendData(0 To m_BufferLength - 1) As Byte
        Call CopyMemory(m_bSendData(0), m_Buffer, m_BufferLength)
        If Index <> -1 Then '作为服务端响应客户端请求
            sckServer(Index).SendData m_bSendData
        Else                '作为客户端向服务端发送请求
            sckClient.SendData m_bSendData
        End If
        frmMain.sbStatus.Panels(2).Text = "发送报文成功"
        DoSendDatagram = True
    Else
        frmMain.sbStatus.Panels(2).Text = "发送报文失败"
        DoSendDatagram = False
    End If
    
End Function

'接收报文处理
Private Sub DoRecvDatagram(Index As Integer)
    Dim DateTime As MYDATETIMESTRUCT

    '响应报文清零
    Call MemSet_HD(m_RspHd8583, &H0, Len(m_RspHd8583))
    
    '是终端响应报文则显示响应码
    If (m_ReqHd8583.Message_Type Mod 2) = HDA_REQMESSAGEOFBACKGROUND Then
        frmMain.sbStatus.Panels(2).Text = "响应码: " + CStr(m_ReqHd8583.Response_Code) + _
                                          ", 等待: " + CStr(TimerOff()) + "毫秒"
        '响应码不等于RC_SUCCESS则直接退出
        If m_ReqHd8583.Response_Code <> RC_SUCCESS Then