應用於實踐的vb socket讀取感測器溫溼度
阿新 • • 發佈：2018-12-11
背景： 應付於基站可能癱瘓的情況，讀取溫溼度並且儲存到資料庫中
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