背景：
应付于基站可能瘫痪的情况，读取温湿度并且存储到数据库中
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim strData As String
Dim num As Integer
Dim i As Integer '代表各个地址
Dim x As Integer '7代表温度 8代表湿度
Dim wd As String 'wd代表温度的解析值
Dim sd As String 'wd代表湿度的解析值
Dim strData1 As String
Dim strData2 As String
Public m As Integer 'm代表6040-6044
Dim sckConnection1 As Boolean
'提取温湿度的数值
Private Function response(sz As String)
Dim b As Integer
Dim n As Integer
Dim a As Double
Dim hex As String
Dim i As Long
Dim y As Integer
hex = Mid(sz, 7, 4)
b = 0
a = 0
For i = 1 To 4
Select Case Mid(hex, 4 - 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
a = b / 10
y = Int(b / 100)
If y = 0 Then
response = "湿度是" & b & "H"
Else
response = "温度是" & a & "C"
End If
End Function
Private Sub insert_num(b As Integer, c, d, e, f As String)
Adodc2.RecordSource = "select * from test"
Adodc2.Recordset.AddNew
Adodc2.Recordset.Fields("date") = Now()
Adodc2.Recordset.Fields("tell") = "地址为" & b & "号"
Adodc2.Recordset.Fields("tnum") = c
Adodc2.Recordset.Fields("hnum") = d
Adodc2.Recordset.Fields("humi") = e
Adodc2.Recordset.Fields("temp") = f
Winsock1.Close '关闭当前套接字
End Sub
Private Sub Form_Load()
Dim s As Integer
On Error Resume Next
m = 0
i = 1
Timer6.Enabled = True
Timer6.Interval = 30000
End Sub
Private Sub Socket()
Dim j As Long
Winsock1.Close
m = m + 1
On Error Resume Next
Select Case m
i = 1
Case 1: Winsock1.LocalPort = 6040
Winsock1.Listen
Case 2: Winsock1.LocalPort = 6041
Winsock1.Listen
Case 3: Winsock1.LocalPort = 6042
Winsock1.Listen
Case 4: Winsock1.LocalPort = 6043
Winsock1.Listen
Case Else:
Winsock1.LocalPort = 6044
Winsock1.Listen
End Select
If m = 5 Then m = 0
'如果端口没有的话怎么办
'判断是否连接了，才发送数据
Timer5.Enabled = True
Timer5.Interval = 3000
End Sub
Private Sub Timer6_Timer()
'总共是5个端口下面多个传感器
Socket
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal RequestID As Long)
Dim myStr As String
If Winsock1.State <> sckClosed Then
Winsock1.Close
Winsock1.Accept RequestID
End If
End Sub
Private Sub Timer5_Timer()
'Timer5.Enabled = False
x = 8
'获取温度测试串
strData1 = ""
Dim bisend(7) As Byte
Dim crc
Dim btLoCRC As Byte, btHiCRC As Byte
Dim Data As Integer
Dim j As Long
If m = 2 Then
Select Case i
Case 1:
bisend(0) = 6
Case 2:
bisend(0) = 40
Case 3:
bisend(0) = 41
Case 4:
bisend(0) = 42
Case 5:
bisend(0) = 43
Case 6:
bisend(0) = 44
Case Else:
bisend(0) = 45
End Select
i = i + 1
If i = 8 Then
i = 1
End If
bisend(1) = 3
bisend(2) = 0
bisend(3) = 8
bisend(4) = 0
bisend(5) = 1
crc = CRC16(bisend, 6, btLoCRC, btHiCRC)
bisend(6) = btLoCRC
bisend(7) = btHiCRC
'判断是否连接了，才发送数据
j = 1
Do Until Winsock1.State = 7 Or j > 600
j = j + 1
DoEvents
Call Sleep(3)
Loop
If j >= 600 Or Winsock1.State = 7 Then
' 1分钟后,对方仍然未同意,连接超时.
End If
Winsock1.SendData bisend
ElseIf m = 1 Then
Select Case i
Case 1:
bisend(0) = 4
Case 2:
bisend(0) = 20
Case 3:
bisend(0) = 21
Case 4:
bisend(0) = 22
Case 5:
bisend(0) = 23
Case Else:
bisend(0) = 24
End Select
i = i + 1
If i = 7 Then
i = 1
End If
bisend(1) = 3
bisend(2) = 0
bisend(3) = 8
bisend(4) = 0
bisend(5) = 1
crc = CRC16(bisend, 6, btLoCRC, btHiCRC)
bisend(6) = btLoCRC
bisend(7) = btHiCRC
'判断是否连接了，才发送数据
j = 1
Do Until Winsock1.State = 7 Or j > 600
j = j + 1
DoEvents
Call Sleep(3)
Loop
If j >= 600 Or Winsock1.State = 7 Then
' 1分钟后,对方仍然未同意,连接超时.
End If
Winsock1.SendData bisend
ElseIf m = 3 Then
Select Case i
Case 1:
bisend(0) = 5
Case 2:
bisend(0) = 30
Case 3:
bisend(0) = 31
Case 4:
bisend(0) = 32
Case Else:
bisend(0) = 33
End Select
i = i + 1
If i = 6 Then
i = 1
End If
bisend(1) = 3
bisend(2) = 0
bisend(3) = 8
bisend(4) = 0
bisend(5) = 1
crc = CRC16(bisend, 6, btLoCRC, btHiCRC)
bisend(6) = btLoCRC
bisend(7) = btHiCRC
'判断是否连接了，才发送数据
j = 1
Do Until Winsock1.State = 7 Or j > 600
j = j + 1
DoEvents
Call Sleep(3)
Loop
If j >= 600 Or Winsock1.State = 7 Then
' 1分钟后,对方仍然未同意,连接超时.
j = j
End If
Winsock1.SendData bisend
ElseIf m = 4 Then
Select Case i
Case 1:
bisend(0) = 50
Case Else:
bisend(0) = 51
End Select
i = i + 1
If i = 3 Then
i = 1
End If
bisend(1) = 3
bisend(2) = 0
bisend(3) = 8
bisend(4) = 0
bisend(5) = 1
crc = CRC16(bisend, 6, btLoCRC, btHiCRC)
bisend(6) = btLoCRC
bisend(7) = btHiCRC
'判断是否连接了，才发送数据
j = 1
Do Until Winsock1.State = 7 Or j > 600
j = j + 1
DoEvents
Call Sleep(3)
Loop
If j >= 600 Or Winsock1.State = 7 Then
' 1分钟后,对方仍然未同意,连接超时
j = j
End If
On Error Resume Next
Winsock1.SendData bisend
Else
Select Case i
Case 1:
bisend(0) = 3
Case 2:
bisend(0) = 10
Case 3:
bisend(0) = 11
Case 4:
bisend(0) = 12
Case Else:
bisend(0) = 13
End Select
i = i + 1
If i = 6 Then
i = 1
End If
bisend(1) = 3
bisend(2) = 0
bisend(3) = 8
bisend(4) = 0
bisend(5) = 1
crc = CRC16(bisend, 6, btLoCRC, btHiCRC)
bisend(6) = btLoCRC
bisend(7) = btHiCRC
'判断是否连接了，才发送数据
j = 1
Do Until Winsock1.State = 7 Or j > 600
j = j + 1
DoEvents
Call Sleep(3)
Loop
If j >= 600 Or Winsock1.State = 7 Then
' 1分钟后,对方仍然未同意,连接超时.
End If
On Error Resume Next
Winsock1.SendData bisend
End If
num = bisend(0)
End Sub
Private Sub Humid(m As Integer)
Dim s As Integer
Dim j As Long
'获取湿度测试串
x = 7
strData2 = ""
Dim bisend(7) As Byte
Dim crc
Dim btLoCRC As Byte, btHiCRC As Byte
Dim Data As Integer
If m = 2 Then
Select Case i
Case 1:
bisend(0) = 6
Case 2:
bisend(0) = 40
Case 3:
bisend(0) = 41
Case 4:
bisend(0) = 42
Case 5:
bisend(0) = 43
Case 6:
bisend(0) = 44
Case Else:
bisend(0) = 45
End Select
i = i + 1
If i = 8 Then
i = 1
End If
bisend(1) = 3
bisend(2) = 0
bisend(3) = 7
bisend(4) = 0
bisend(5) = 1
crc = CRC16(bisend, 6, btLoCRC, btHiCRC)
bisend(6) = btLoCRC
bisend(7) = btHiCRC
'判断是否连接了，才发送数据
j = 1
Do Until Winsock1.State = 7 Or j > 600
j = j + 1
DoEvents
Call Sleep(3)
Loop
If j >= 600 Or Winsock1.State = 7 Then
' 1分钟后,对方仍然未同意,连接超时.
End If
Winsock1.SendData bisend
ElseIf m = 1 Then
Select Case i
Case 1:
bisend(0) = 4
Case 2:
bisend(0) = 20
Case 3:
bisend(0) = 21
Case 4:
bisend(0) = 22
Case 5:
bisend(0) = 23
Case Else:
bisend(0) = 24
End Select
i = i + 1
If i = 7 Then
i = 1
End If
bisend(1) = 3
bisend(2) = 0
bisend(3) = 7
bisend(4) = 0
bisend(5) = 1
crc = CRC16(bisend, 6, btLoCRC, btHiCRC)
bisend(6) = btLoCRC
bisend(7) = btHiCRC
'判断是否连接了，才发送数据
j = 1
Do Until Winsock1.State = 7 Or j > 600
j = j + 1
DoEvents
Call Sleep(3)
Loop
If j >= 600 Or Winsock1.State = 7 Then
' 1分钟后,对方仍然未同意,连接超时.
End If
Winsock1.SendData bisend
ElseIf m = 3 Then
Select Case i
Case 1:
bisend(0) = 5
Case 2:
bisend(0) = 30
Case 3:
bisend(0) = 31
Case 4:
bisend(0) = 32
Case Else:
bisend(0) = 33
End Select
i = i + 1
If i = 6 Then
i = 1
End If
bisend(1) = 3
bisend(2) = 0
bisend(3) = 7
bisend(4) = 0
bisend(5) = 1
crc = CRC16(bisend, 6, btLoCRC, btHiCRC)
bisend(6) = btLoCRC
bisend(7) = btHiCRC
'判断是否连接了，才发送数据
j = 1
Do Until Winsock1.State = 7 Or j > 600
j = j + 1
DoEvents
Call Sleep(3)
Loop
If j >= 600 Or Winsock1.State = 7 Then
' 1分钟后,对方仍然未同意,连接超时.
End If
Winsock1.SendData bisend
ElseIf m = 4 Then
Select Case i
Case 1:
bisend(0) = 50
Case Else:
bisend(0) = 51
End Select
i = i + 1
If i = 3 Then
i = 1
End If
bisend(1) = 3
bisend(2) = 0
bisend(3) = 7
bisend(4) = 0
bisend(5) = 1
crc = CRC16(bisend, 6, btLoCRC, btHiCRC)
bisend(6) = btLoCRC
bisend(7) = btHiCRC
'判断是否连接了，才发送数据
j = 1
Do Until Winsock1.State = 7 Or j > 600
j = j + 1
DoEvents
Call Sleep(3)
Loop
If j >= 600 Or Winsock1.State = 7 Then
' 1分钟后,对方仍然未同意,连接超时.
End If
Winsock1.SendData bisend
Else
Select Case i
Case 1:
bisend(0) = 3
Case 2:
bisend(0) = 10
Case 3:
bisend(0) = 11
Case 4:
bisend(0) = 12
Case Else:
bisend(0) = 13
End Select
i = i + 1
If i = 6 Then
i = 1
End If
bisend(1) = 3
bisend(2) = 0
bisend(3) = 7
bisend(4) = 0
bisend(5) = 1
crc = CRC16(bisend, 6, btLoCRC, btHiCRC)
bisend(6) = btLoCRC
bisend(7) = btHiCRC
'判断是否连接了，才发送数据
j = 1
Do Until Winsock1.State = 7 Or j > 600
j = j + 1
DoEvents
Call Sleep(3)
Loop
If j >= 600 Or Winsock1.State = 7 Then
' 1分钟后,对方仍然未同意,连接超时.
End If
Winsock1.SendData bisend
End If
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim a As String
Dim b As String
Dim myStr() As Byte
myStr = ""
strData = ""
Winsock1.GetData myStr
Dim i As Integer
Dim crc
Dim btLoCRC As Byte, btHiCRC As Byte
If myStr(1) = 3 Then '读寄存器
'CRC校验
crc = CRC16(myStr, UBound(myStr) - LBound(myStr) - 1, btLoCRC, btHiCRC)
If myStr(UBound(myStr) - 1) = btLoCRC And myStr(UBound(myStr)) = btHiCRC Then
'校验正确
For i = 0 To UBound(myStr)
If Len(hex(myStr(i))) = 1 Then
strData = strData & "0" & hex(myStr(i))
Else
strData = strData & hex(myStr(i))
End If
Next
End If
End If
If x = 8 Then '湿度
Text2.Text = strData
strData1 = strData
Print "湿度:" & strData
Print "湿度:" & Text2.Text
sd = response(strData1)
Print "xxxxxxx:" & sd
Humid m
ElseIf x = 7 Then
Text1.Text = strData
strData2 = strData
wd = response(Text1.Text)
End If
If Text1.Text <> "" And Text2.Text <> "" And strData2 <> "" And strData1 <> "" Then
Call insert_num(num, strData2, strData1, sd, wd)
End If
End Sub
Function CRC16(Data() As Byte, no As Integer, CRC16Lo As Byte, CRC16Hi As Byte) As String
Dim CL As Byte, CH As Byte '多项式码&HA001
Dim SaveHi As Byte, SaveLo As Byte
Dim i As Integer
Dim Flag As Integer
CRC16Lo = &HFF '255
CRC16Hi = &HFF '255
CL = &H1 '1
CH = &HA0 '160
For i = 0 To no - 1
CRC16Lo = CRC16Lo Xor Data(i) '每一个数据与CRC寄存器进行异或
For Flag = 0 To 7
SaveHi = CRC16Hi
SaveLo = CRC16Lo
CRC16Hi = CRC16Hi \ 2 '高位右移一位
CRC16Lo = CRC16Lo \ 2 '低位右移一位
If ((SaveHi And &H1) = &H1) Then '如果高位字节最后一位为1
CRC16Lo = CRC16Lo Or &H80 '则低位字节右移后前面补1
End If '否则自动补0
If ((SaveLo And &H1) = &H1) Then '如果LSB为1，则与多项式码进行异或
CRC16Hi = CRC16Hi Xor CH
CRC16Lo = CRC16Lo Xor CL
End If
Next Flag
Next i
Dim ReturnData(1) As Byte
ReturnData(0) = CRC16Hi 'CRC高位
ReturnData(1) = CRC16Lo 'CRC低位
CRC16 = ReturnData
End Function