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
