1,502
社区成员
发帖
与我相关
我的任务
分享
Dim VIS_DATA(1) As Long
Dim str1() As Byte
Dim cs As Integer
Dim postData As String
Dim url As String
Dim HttpClient As Object
Private Sub Form_Load()
cs = 1000
With Winsockreceive
'.RemoteHost = "192.168.3.188"
'.RemotePort = 8080
.LocalPort = 8080
.Bind (8080)
End With
End Sub
' 用途:将十六进制转化为十进制
' 输入:Hex(十六进制数)
' 输入数据类型:String
' 输出:HEX_to_DEC(十进制数)
' 输出数据类型:Long
' 输入的最大数为7FFFFFFF,输出的最大数为2147483647
Public Function HEX_to_DEC(ByVal Hex As String) As Long
Dim i As Long
Dim B As Long
Hex = UCase(Hex)
For i = 1 To Len(Hex)
Select Case Mid(Hex, Len(Hex) - i + 1, 1)
Case "0": B = B + 16 ^ (i - 1) * 0
Case "1": B = B + 16 ^ (i - 1) * 1
Case "2": B = B + 16 ^ (i - 1) * 2
Case "3": B = B + 16 ^ (i - 1) * 3
Case "4": B = B + 16 ^ (i - 1) * 4
Case "5": B = B + 16 ^ (i - 1) * 5
Case "6": B = B + 16 ^ (i - 1) * 6
Case "7": B = B + 16 ^ (i - 1) * 7
Case "8": B = B + 16 ^ (i - 1) * 8
Case "9": B = B + 16 ^ (i - 1) * 9
Case "A": B = B + 16 ^ (i - 1) * 10
Case "B": B = B + 16 ^ (i - 1) * 11
Case "C": B = B + 16 ^ (i - 1) * 12
Case "D": B = B + 16 ^ (i - 1) * 13
Case "E": B = B + 16 ^ (i - 1) * 14
Case "F": B = B + 16 ^ (i - 1) * 15
End Select
Next i
HEX_to_DEC = B
End Function
Private Function pvToByteArray(sText As String) As Byte()
'pvToByteArray = GB2312ToUTF8(sText)
pvToByteArray = sText
End Function
Public Function GB2312ToUTF8(strIn As String, Optional ByVal ReturnValueType As VbVarType = vbString) As Variant
Dim adoStream As Object
Set adoStream = CreateObject("ADODB.Stream")
adoStream.Charset = "utf-8"
adoStream.Type = 2 'adTypeText
adoStream.Open
adoStream.WriteText strIn
adoStream.Position = 0
adoStream.Type = 1 'adTypeBinary
GB2312ToUTF8 = adoStream.Read()
adoStream.Close
If ReturnValueType = vbString Then GB2312ToUTF8 = Mid(GB2312ToUTF8, 1)
End Function
Private Sub Winsockreceive_DataArrival(ByVal bytesTotal As Long)
Dim str As String
Winsockreceive.GetData str
str1() = str
cd = Len(str)
'If Len(str) = 15 Then
For i = LBound(str1()) To UBound(str1())
If Len(Hex(str1(i))) = 1 And Hex(str1(i)) <> 0 Then
HData = HData & "0" & Hex(str1(i))
HData1 = HData1 & " 0" & Hex(str1(i))
ElseIf Hex(str1(i)) = 0 Then
HData = HData
HData1 = HData1
Else
HData = HData & Hex(str1(i))
HData1 = HData1 & " " & Hex(str1(i))
End If
Next
'HData = Left(HData, 22) & "0000" & Right(HData, 4)
bianhao = HEX_to_DEC(Left(HData, 8))
wendu = Round(HEX_to_DEC(Mid(HData, 15, 4)) / 10, 1)
shidu = Round(HEX_to_DEC(Mid(HData, 19, 4)) / 10, 1)
If cs >= 1011 Then
cs = 1000
Text1 = "序号:" & cs & " 编码:" & HData1 & " 长度:" & cd & " 时间:" & Time() & vbCrLf
Else
Text1 = Text1 & "序号:" & cs & " 编码:" & HData1 & " 长度:" & cd & " 时间:" & Time() & vbCrLf
End If
cs = cs + 1
Text2 = bianhao
Text3 = wendu & "度"
Text4 = shidu & "百分之"
Text5 = Time()
Text8 = cd
'--- post 数据到服务器---
postData = "?appcode=0AjRIorK7@1pGxwQ&deviceid=" & bianhao & "&a1=" & wendu & "&a2=" & shidu & "&cd=" & Len(str)
url = Text6 & postData
Set HttpClient = CreateObject("Microsoft.XMLHTTP")
HttpClient.Open "POST", url, False
HttpClient.setRequestHeader "Content-Type", "text/xml; charset=gb2312"
HttpClient.Send pvToByteArray(postData)
Do While HttpClient.readyState <> 4
DoEvents
Loop
jg = HttpClient.responseText
Select Case jg
Case 0
jg = "缺少数据"
Case 1
jg = "温度异常"
Case 2
jg = "湿度异常"
Case 8
jg = "发送成功"
End Select
Text7 = jg
'--- post 数据到服务器---
'End If
End Sub
Dim strInput As String
Dim sglOutput As Single
strInput = "3F68"
sglOutput = Round(Val("&H" + strInput) / 10, 1)
Debug.Print sglOutput
Dim sglInput As Single
Dim strOutput As String
sglInput = 1623.2
strOutput = Hex(sglInput * 10)
Debug.Print strOutput