GSM-串口和GPRS-网口通信

Option Explicit

'************************************************
'******************COM 端口设置******************
'************************************************
Public Function COMSet(CommObj As MSComm, ByVal mPort As String, ByVal mSet As String) As Boolean
    On Error GoTo Err
    If CommObj.PortOpen = True Then CommObj.PortOpen = False
    CommObj.InBufferSize = 1024
    CommObj.OutBufferSize = 512
    CommObj.CommPort = mPort
    CommObj.Settings = mSet
    CommObj.PortOpen = True
    CommObj.RThreshold = 1
    CommObj.NullDiscard = False
    CommObj.InputLen = 0
    CommObj.SThreshold = 1
    CommObj.InputMode = comInputModeBinary
    COMSet = True
    Exit Function
Err:
    COMSet = False
End Function

'************************************************
'****************十六进制转十进制****************
'************************************************
Public Function HexToDec(HexValue As Variant) As Variant
    Dim LowValue, HighValue As String
    
    If Len(HexValue) = 1 Then
       HexValue = "0" & HexValue
    End If
    Select Case Left(HexValue, 1)
           Case "A"
                LowValue = "10"
           Case "B"
                LowValue = "11"
           Case "C"
                LowValue = "12"
           Case "D"
                LowValue = "13"
           Case "E"
                LowValue = "14"
           Case "F"
                LowValue = "15"
           Case Else
                LowValue = Left(HexValue, 1)
    End Select
    Select Case Right(HexValue, 1)
           Case "A"
                HighValue = "10"
           Case "B"
                HighValue = "11"
           Case "C"
                HighValue = "12"
           Case "D"
                HighValue = "13"
           Case "E"
                HighValue = "14"
           Case "F"
                HighValue = "15"
           Case Else
                HighValue = Right(HexValue, 1)
    End Select
    HexToDec = Val(LowValue) * 16 + Val(HighValue)
End Function

'************************************************
'***********判断发送数据是否是十六进制***********
'************************************************
Public Function OpinHEX(strobj As String) As Boolean
    Dim i As Long
    If Len(strobj) Mod 2 = 0 Then
        OpinHEX = True
    Else
        OpinHEX = False
        Exit Function
    End If
    For i = 1 To Len(strobj)
        If (Asc(Mid(strobj, i, 1)) >= 48 And Asc(Mid(strobj, i, 1)) <= 57) Or (Asc(Mid(strobj, i, 1)) >= 65 And Asc(Mid(strobj, i, 1)) <= 70) Then
            OpinHEX = True
        Else
            OpinHEX = False
            Exit Function
        End If
    Next
End Function

'************************************************
'***将接收到的十六进制数据转换为中文***
'************************************************
Public Function HexToChinese_RHR(DataStr As String) As String
    Dim i As Long, j As Long
    i = Len(DataStr) \ 4
    For j = 0 To i - 1
        HexToChinese_RHR = HexToChinese_RHR & ChrW(HexToDec(Mid(DataStr, 1 + 4 * j, 2)) * 256 + HexToDec(Mid(DataStr, 1 + 2 + 4 * j, 2)))
    Next
End Function

'************************************************
'****将接收到的十六进制数据转换为中文（标准）****
'************************************************
Public Function HexToChinese_Stand(DataStr As String) As String
    Dim i As Long, j As Long
    i = Len(DataStr) \ 4
    For j = 0 To i - 1
        HexToChinese_Stand = HexToChinese_Stand & Chr(HexToDec(Mid(DataStr, 1 + 4 * j, 2)) * 256 + HexToDec(Mid(DataStr, 1 + 2 + 4 * j, 2)))
    Next
End Function

'************************************************
'********将接收到的中文转换为十六进制数据********
'************************************************
Public Function ChineseToHex(DataStr As String) As String
    Dim i As Long, j As Long
    Dim DataStr_Tmp As String
    
    For i = 0 To Len(DataStr) - 1
        DataStr_Tmp = Hex(AscW(Mid(DataStr, i + 1, 1)))
        For j = 1 To 4 - Len(DataStr_Tmp)
            DataStr_Tmp = "0" & DataStr_Tmp
        Next
        ChineseToHex = ChineseToHex & DataStr_Tmp
    Next
End Function

'************************************************
'**************将数据转换为十六进制**************
'************************************************
Public Function HEXData(DataStr As String) As String
    Dim DataStr_Tmp As String
    Dim SendData As String
    Dim i As Long
    
    '去掉字符串中的空格
    DataStr_Tmp = DelBlank(DataStr)
    '转换为十进制
    For i = 1 To Len(DataStr_Tmp) \ 2
        SendData = SendData & Chr(HexToDec(Mid(DataStr_Tmp, 2 * (i - 1) + 1, 2)))
    Next
    HEXData = SendData
End Function

'************************************************
'************以GSM按 十六进制发送数据************
'************************************************
Public Function GSM_SendHEX(DataStr As String)
    Dim DataStr_Tmp As String
    Dim SendData() As Byte
    Dim i As Long
    
    '去掉字符串中的空格
    DataStr_Tmp = DelBlank(DataStr)
    '发送数据
    ReDim SendData(Len(DataStr_Tmp) \ 2 - 1) As Byte
    For i = 1 To Len(DataStr_Tmp) \ 2
        SendData(i - 1) = HexToDec(Mid(DataStr_Tmp, 2 * (i - 1) + 1, 2))
    Next
    
    FrmMain.MSComm1.Output = SendData
End Function

'************************************************
'*************以GSM按ASCII码发送数据*************
'************************************************
Public Function GSM_SendASCII(DataStr As String)
    Dim DataStr_Tmp As String
    Dim SendData() As Byte
    Dim i As Long
    
    '去掉字符串中的空格
    DataStr_Tmp = DelBlank(DataStr)
    '发送数据
    ReDim SendData(Len(DataStr_Tmp) - 1) As Byte
    For i = 1 To Len(DataStr_Tmp)
        SendData(i - 1) = Asc(Mid(DataStr_Tmp, i, 1))
    Next
    
    FrmMain.MSComm1.Output = SendData
End Function

'************************************************
'********以GPRS按十六进制发送数据 （TCP）********
'************************************************
Public Function GPRS_SendHEX_TCP(DataStr As String, IDString As String)
    Dim DataStr_Tmp As String
    Dim SendData() As Byte
    Dim i As Long
    
    '去掉字符串中的空格
    DataStr_Tmp = DelBlank(DataStr)
    '发送数据
    ReDim SendData(Len(DataStr_Tmp) \ 2 - 1) As Byte
    For i = 1 To Len(DataStr_Tmp) \ 2
        SendData(i - 1) = HexToDec(Mid(DataStr_Tmp, 2 * (i - 1) + 1, 2))
    Next
    FrmMain.Winsock2(IDString).SendData SendData
End Function

'************************************************
'*********以GPRS按ASCII码发送数据（TCP）*********
'************************************************
Public Function GPRS_SendASCII_TCP(DataStr As String, IDString As String)
    Dim DataStr_Tmp As String
    Dim i As Long
    
    '转换数据
    DataStr_Tmp = DataStr
    
    FrmMain.Winsock2(IDString).SendData DataStr_Tmp
End Function

'************************************************
'********以GPRS按十六进制发送数据 （UDP）********
'************************************************
Public Function GPRS_SendHEX_UDP(DataStr As String, IDString As String)
    Dim DataStr_Tmp As String
    Dim SendData() As Byte
    Dim i As Long
    
    '去掉字符串中的空格
    DataStr_Tmp = DelBlank(DataStr)
    '发送数据
    ReDim SendData(Len(DataStr_Tmp) \ 2 - 1) As Byte
    For i = 1 To Len(DataStr_Tmp) \ 2
        SendData(i - 1) = HexToDec(Mid(DataStr_Tmp, 2 * (i - 1) + 1, 2))
    Next
    FrmMain.Winsock3(IDString).SendData SendData
End Function

'************************************************
'*********以GPRS按ASCII码发送数据（UDP）*********
'************************************************
Public Function GPRS_SendASCII_UDP(DataStr As String, IDString As String)
    Dim DataStr_Tmp As String
    Dim i As Long
    
    '转换数据
    DataStr_Tmp = DataStr
    
    FrmMain.Winsock3(IDString).SendData DataStr_Tmp
End Function