调用TCP/IP通讯客户端的VB6样例

'Public模块

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''引用通讯动态库：VM2003_Comm.dll
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Declare Function VM2003_Connect Lib "GDW_VM2003_Comm.dll" ( _
                 ByVal hwnd As Long, _
                 ByVal dwMsgDataReady As Long, _
                 ByVal dwMsgConnectSuccess As Long, _
                 ByVal dwMsgDisconnect As Long _
                 ) As Long

Declare Function VM2003_GetVehicleInfo Lib "GDW_VM2003_Comm.dll" ( _
                 ByVal pchPlate$, _
                 ByVal pchTime$, _
                 ByRef pbtImageBin As Byte, _
                 ByRef pbtImagePlate As Byte, _
                 ByRef dwImagePlateSize As Long, _
                 ByRef pbtImageNear As Byte, _
                 ByRef dwImageNearSize As Long, _
                 ByRef pbtImageFull As Byte, _
                 ByRef dwImageFullSize As Long, _
                 ByVal pchDeviceId$, _
                 ByRef iRoadWay As Long, _
                 ByRef iSpeed As Long, _
                 ByRef iSpeedLimit As Long, _
                 ByRef dwDeviceState As Long _
                 ) As Long
                
Declare Function VM2003_AdjustTime Lib "GDW_VM2003_Comm.dll" ( _
                 ByVal pchPlate$ _
                 ) As Long
                
Declare Function VM2003_Disconnect Lib "GDW_VM2003_Comm.dll" () As Long

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''引用操作系统API
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
                    ByVal lpvDest As Long, _
                    ByVal lpvSource As Long, _
                    ByVal cbCopy As Long)
                   
                    Public Const MAX_PATH = 260             '// WIN32_FIND_DATA中的文件名最长限制值
Public Const INVALID_HANDLE_VALUE = -1  '// FindFirstFile发生错误时的返回值

'// WIN32_FIND_DATA中使用的文件时间
Public Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

'// FindFirstFile、FindNextFile中使用的参数类型，返回文件参数
Public Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime   As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime  As FILETIME
        nFileSizeHigh    As Long
        nFileSizeLow     As Long
        dwReserved0      As Long
        dwReserved1      As Long
        cFileName        As String * MAX_PATH
        cAlternate       As String * 14
End Type

'// CreateDirectory中使用的结构
Public Type SECURITY_ATTRIBUTES
        nLength              As Long
        lpSecurityDescriptor As Long
        bInheritHandle       As Long
End Type

'// 创建一个新目录
'// 非零表示成功，零表示失败。会设置GetLastError
Public Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" ( _
                        ByVal lpNewDirectory As String, _
                        ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES _
                        ) As Long

'// 根据文件名查找文件
'// 执行成功，返回一个搜索句柄。如果出错，返回一个INVALID_HANDLE_VALUE常数，一旦不再需要，应该用FindClose函数关闭这个句柄
Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
                        ByVal lpFileName As String, _
                        ByRef lpFindFileData As WIN32_FIND_DATA _
                        ) As Long
                       
'// 关闭由FindFirstFile函数创建的一个搜索句柄
'// 非零表示成功，零表示失败。会设置GetLastError
Public Declare Function FindClose Lib "kernel32" ( _
                        ByVal hFindFile As Long _
                        ) As Long
                       
'// 删除指定文件
'// 非零表示成功，零表示失败。会设置GetLastError
Public Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" ( _
                        ByVal lpFileName As String _
                        ) As Long
                   
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''自定义公共函数
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Rem 从 保存牌照号码的字符串缓冲区 取出牌照号码字符串
Public Function GetStringFromBuff(strPlateBuff As String) As String
    On Error GoTo ErrHandle
   
    Dim i       As Integer
    Dim bytChar As Byte
     
    For i = 1 To Len(strPlateBuff)
        bytChar = AscB(Mid(strPlateBuff, i, 1))
        If bytChar = 0 Then
            GetStringFromBuff = Mid(strPlateBuff, 1, i - 1)
            Exit Function
        End If
    Next i
   
    Exit Function
ErrHandle:
    GetStringFromBuff = "Error"
End Function

Public Sub WriteToLog(ByVal szPosition As String, _
                      ByVal szDescription As String, _
                      ByVal iEventSign As Integer, _
                      Optional ByVal bNewSeparate As Boolean = False)

    On Error GoTo ErrHandle
   
    Dim szLogFileName        As String
    Dim iFileNumber          As Integer
    Dim szCurrentTime        As String
    Dim lpWin32FileData      As WIN32_FIND_DATA
    Dim nFindFileHandle      As Long
   
    szCurrentTime = Format$(Date$, "yyyy-MM-dd") & Space(1) & Format$(Time$, "HH:mm:ss")
   
    szLogFileName = App.Path & "/DemoForClient.evt"
    iFileNumber = FreeFile
   
    nFindFileHandle = FindFirstFile(szLogFileName, lpWin32FileData)
    Call FindClose(nFindFileHandle)
   
    If INVALID_HANDLE_VALUE = nFindFileHandle Then  '// 如果系统日志文件不存在则创建
        Open szLogFileName For Output As #iFileNumber
            If bNewSeparate Then
                Print #iFileNumber, ""
            End If
            Print #iFileNumber, szCurrentTime & "|" & szPosition & "|" & szDescription & "|" & iEventSign
        Close #iFileNumber
    Else                                            '// 如果系统日志文件存在则追加
        If lpWin32FileData.nFileSizeLow > 51120 Then
            DoEvents
            DeleteFile szLogFileName
            DoEvents
            Open szLogFileName For Output As #iFileNumber
                If bNewSeparate Then
                    Print #iFileNumber, ""
                End If
                Print #iFileNumber, szCurrentTime & "|" & szPosition & "|" & szDescription & "|" & iEventSign
            Close #iFileNumber
        Else
            Open szLogFileName For Append As #iFileNumber
                If bNewSeparate Then
                    Print #iFileNumber, ""
                End If
                Print #iFileNumber, szCurrentTime & "|" & szPosition & "|" & szDescription & "|" & iEventSign
            Close #iFileNumber
        End If
    End If
   
    Exit Sub
ErrHandle:
    Close #iFileNumber
End Sub

'Msg模块

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''引用系统动态库
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const WM_MsgDataReady = &H401 ' 自定义消息：数据准备好
Public Const WM_MsgConnectSuccess = &H402 ' 自定义消息：网络连接成功
Public Const WM_MsgDisconnect = &H403 ' 自定义消息：网络连接失败

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
                         ByVal lpPrevWndFunc As Long, _
                         ByVal hwnd As Long, _
                         ByVal Msg As Long, _
                         ByVal wParam As Long, _
                         ByVal lParam As Long _
                         ) As Long

Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" ( _
                         ByVal hwnd As Long, _
                         ByVal wMsg As Long, _
                         ByVal wParam As Long, _
                         ByVal lParam As Long _
                         ) As Long

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
                         ByVal lpClassName As String, _
                         ByVal lpWindowName As String _
                         ) As Long

Public Const GWL_WNDPROC = (-4)

Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
                         ByVal hwnd As Long, _
                         ByVal nIndex As Long _
                         ) As Long
                        
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
                         ByVal hwnd As Long, _
                         ByVal nIndex As Long, _
                         ByVal dwNewLong As Long _
                         ) As Long
                        
''创建全局变量
Global gprevWndproc As Long ' 保存窗体消息处理句柄，用于退出程序时恢复Windows消息处理
Global gbNetIsOk As Boolean ' 保存网络连接状态

                        
'/*================================================================
' *
' * 函 数 名：WndProc
' *
' * 参    数：ByVal hwnd   As Long
' *           ByVal Msg    As Long  消息代码
' *           ByVal wParam As Long
' *           ByVal lParam As Long
' *
' * 功能描述: 截获窗体消息，处理自定义消息，其余消息归还Windows处理
' *
' * 返 回 值：默认
' *
' * 异常处理：跳到下一行继续执行
' *
' * 作    者：Shi.Mingjie 2003/07/15
' *
' ================================================================*/
Public Function WndProc(ByVal hwnd As Long, _
                        ByVal Msg As Long, _
                        ByVal wParam As Long, _
                        ByVal lParam As Long) As Long
                       
    On Error Resume Next
                
    Select Case Msg
    Case WM_MsgDataReady
        Call frmMain.GetVehicleInfo
    Case WM_MsgConnectSuccess
        Call frmMain.ShowNetState("网络状态：连接成功")
    Case WM_MsgDisconnect
        Call frmMain.ShowNetState("网络状态：断开")
    Case Else ' 其它消息交由Windows处理
        WndProc = CallWindowProc(gprevWndproc, hwnd, Msg, wParam, lParam)
    End Select
   
End Function

 

'主界面代码

Option Explicit
   
Private Type UDTVehicleInfo
        pchPlate As String * 20
        pchTime As String * 20
        dwImagePlateSize As Long
        dwImageNearSize As Long
        dwImageFullSize As Long
        pchDeviceId As String * 20
        iRoadWay As Long
        iSpeed As Long
        iSpeedLimit As Long
        dwDeviceState As Long
End Type

Private m_pbtImageBin(279) As Byte
Private m_pbtImagePlate(5000) As Byte
Private m_pbtImageNear(102400) As Byte
Private m_pbtImageFull(102400) As Byte
Private m_pbtWriteData() As Byte
Private m_udtVehicle As UDTVehicleInfo
Private m_nReceiveCount As Long

Private Function SaveAsBinaryFile() As Boolean
    On Error GoTo ErrHandle
   
    Dim szFileName As String
    Dim iFileNumber As Integer
    Dim k As Long
   
    Call WriteToLog("SaveAsBinaryFile", "debug: image near size " & m_udtVehicle.dwImageNearSize, 1)

    ReDim m_pbtWriteData(0 To m_udtVehicle.dwImageNearSize - 1) As Byte
    Call CopyMemory(VarPtr(m_pbtWriteData(0)), VarPtr(m_pbtImageNear(0)), m_udtVehicle.dwImageNearSize)
'    For k = 0 To m_udtVehicle.dwImageNearSize - 1
'        m_pbtWriteData(k) = m_pbtImageNear(k)
'    Next k
   
    szFileName = App.Path & "/n.jpg"
    iFileNumber = FreeFile
    Open szFileName For Binary Access Write Lock Read As #iFileNumber
        Put #iFileNumber, , m_pbtWriteData()
    Close #iFileNumber
   
    Call WriteToLog("SaveAsBinaryFile", "debug: image full size " & m_udtVehicle.dwImageFullSize, 1)
   
    ReDim m_pbtWriteData(0 To m_udtVehicle.dwImageFullSize - 1) As Byte
    Call CopyMemory(VarPtr(m_pbtWriteData(0)), VarPtr(m_pbtImageFull(0)), m_udtVehicle.dwImageFullSize)
'    For k = 0 To m_udtVehicle.dwImageFullSize - 1
'        m_pbtWriteData(k) = m_pbtImageFull(k)
'    Next k
   
    szFileName = App.Path & "/f.jpg"
    iFileNumber = FreeFile
    Open szFileName For Binary Access Write Lock Read As #iFileNumber
        Put #iFileNumber, , m_pbtWriteData()
    Close #iFileNumber
   
    SaveAsBinaryFile = True
    Exit Function
ErrHandle:
    SaveAsBinaryFile = False
    Close #iFileNumber
    Call WriteToLog("SaveAsBinaryFile", Err.Number & ":" & Err.Description, 4, False)
End Function

Private Sub ShowVehicleInfo()
    On Error Resume Next
   
    Dim szMsg As String
    Dim szPlate As String
    Dim szPassTime As String
    Dim szDeviceId As String
   
    szPlate = GetStringFromBuff(m_udtVehicle.pchPlate)
    szPassTime = GetStringFromBuff(m_udtVehicle.pchTime)
    szDeviceId = GetStringFromBuff(m_udtVehicle.pchDeviceId)
   
    szMsg = "车牌：" & szPlate & vbCrLf & _
        "通行时间：" & szPassTime & vbCrLf & _
        "设备编号：" & szDeviceId & vbCrLf & _
        "车道号：" & m_udtVehicle.iRoadWay & vbCrLf & _
        "车速：" & m_udtVehicle.iSpeed & vbCrLf & _
        "限速：" & m_udtVehicle.iSpeedLimit & vbCrLf & _
        "设备状态：" & m_udtVehicle.dwDeviceState & vbCrLf & _
        "特写图片大小：" & m_udtVehicle.dwImageNearSize & vbCrLf & _
        "全景图片大小：" & m_udtVehicle.dwImageFullSize
         
    txtVehicleInfo.Text = szMsg
   
    lblReceiveCount = "收到：" & m_nReceiveCount
   
    Dim szImageNearPath As String
    Dim szImageFullPath As String
    Dim lpWin32FileData      As WIN32_FIND_DATA
    Dim nFindFileHandle      As Long
   
    szImageNearPath = App.Path & "/n.jpg"
    szImageFullPath = App.Path & "/f.jpg"
   
    nFindFileHandle = FindFirstFile(szImageNearPath, lpWin32FileData)
    Call FindClose(nFindFileHandle)
    picNear.Picture = Nothing
    If INVALID_HANDLE_VALUE <> nFindFileHandle Then '文件不存在
        picNear.Picture = LoadPicture(szImageNearPath)
    End If
   
    nFindFileHandle = FindFirstFile(szImageFullPath, lpWin32FileData)
    Call FindClose(nFindFileHandle)
    picFull.Picture = Nothing
    If INVALID_HANDLE_VALUE <> nFindFileHandle Then '文件不存在
        picFull.Picture = LoadPicture(szImageFullPath)
    End If
End Sub

Public Sub GetVehicleInfo()
    On Error GoTo ErrHandle
   
    Dim nRet As Long
    nRet = VM2003_GetVehicleInfo(m_udtVehicle.pchPlate, m_udtVehicle.pchTime, m_pbtImageBin(0), _
        m_pbtImagePlate(0), m_udtVehicle.dwImagePlateSize, m_pbtImageNear(0), m_udtVehicle.dwImageNearSize, m_pbtImageFull(0), _
        m_udtVehicle.dwImageFullSize, m_udtVehicle.pchDeviceId, m_udtVehicle.iRoadWay, m_udtVehicle.iSpeed, _
        m_udtVehicle.iSpeedLimit, m_udtVehicle.dwDeviceState)
   
    If nRet <> 0 Then
        Call MsgBox("GDW_VM2003_GetVehicleInfo失败，返回：" & nRet, vbCritical, "失败提示！")
    Else ' 进行保存图片和显示
        m_nReceiveCount = m_nReceiveCount + 1
        Call SaveAsBinaryFile
        Call ShowVehicleInfo
    End If
       
    Exit Sub
ErrHandle:
    Call MsgBox("GetVehicleInfo时发生错误！" & vbCrLf & _
                "错误号：" & Err.Number & vbCrLf & _
                "系统提示原因：" & Err.Description, vbCritical, "警告提示信息！")
End Sub

Public Sub ShowNetState(ByVal szState As String)
    lblNetState.Caption = szState
End Sub

Private Sub cmdAdjustTime_Click()
    Dim nRet As Long
   
    nRet = VM2003_AdjustTime("")
   
    If nRet <> 0 Then
        Call MsgBox("GDW_VM2003_AdjustTime失败，返回：" & nRet, vbCritical, "失败提示！")
    End If
End Sub

Private Sub cmdConnect_Click()
    Dim nRet As Long
   
    nRet = VM2003_Connect(Me.hwnd, WM_MsgDataReady, WM_MsgConnectSuccess, WM_MsgDisconnect)
   
    If nRet <> 0 Then
        Call MsgBox("GDW_VM2003_Connect失败，返回：" & nRet, vbCritical, "失败提示！")
    Else
        cmdConnect.Enabled = False
        cmdAdjustTime.Enabled = True
        cmdDisconnect.Enabled = True
    End If
End Sub

Private Sub cmdDisconnect_Click()
    Dim nRet As Long
   
    nRet = VM2003_Disconnect()
   
    If nRet <> 0 Then
        Call MsgBox("GDW_VM2003_Disconnect失败，返回：" & nRet, vbCritical, "失败提示！")
    Else
        cmdConnect.Enabled = True
        cmdAdjustTime.Enabled = False
        cmdDisconnect.Enabled = False
    End If
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    On Error GoTo ErrHandle
   
    Dim i As Long
   
    Caption = "客户端样例 V" & App.Major & "." & App.Minor & "." & App.Revision & "  " & App.Comments
    cmdConnect.Enabled = True
    cmdAdjustTime.Enabled = False
    cmdDisconnect.Enabled = False
   
    gprevWndproc = GetWindowLong(Me.hwnd, GWL_WNDPROC) ' 获取当前消息处理句柄
    SetWindowLong Me.hwnd, GWL_WNDPROC, AddressOf WndProc ' 设置当前消息处理函数
   
    m_nReceiveCount = 0
   
    Exit Sub
ErrHandle:
    Call MsgBox("Form_Load时发生错误！" & vbCrLf & _
                "错误号：" & Err.Number & vbCrLf & _
                "系统提示原因：" & Err.Description, vbCritical, "警告提示信息！")
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If cmdDisconnect.Enabled Then
        Call cmdDisconnect_Click
    End If
    SetWindowLong Me.hwnd, GWL_WNDPROC, gprevWndproc ' 恢复消息Windows处理
End Sub