菜鳥编程园地

 找回密码
 立即注册

QQ登录

只需一步,快速开始

查看: 1316|回复: 1

【CBM666 Winsock 通讯】

[复制链接]

34

主题

36

帖子

74

积分

超级版主

Rank: 8Rank: 8

积分
74
QQ
发表于 2020-7-27 11:46:42 | 显示全部楼层 |阅读模式
本帖最后由 cbm666 于 2020-7-27 12:00 编辑



【本代码来源出处:CBM666 VB6 编程教材】
'******************************************* Server 服务端
Private Sub Form_Load()
   On Error Resume Next                                  '错误处理
   SkinH_Attach                                          '加载皮肤
   SkinH_AttachEx AppDisk & "淡雅流光.she", vbNullString '使用默认风格.she的皮肤
   Call SkinH_SetWindowAlpha(Me.hwnd, 255)       '透明度255
   Me.Caption = "服务器"
   Text1.Text = Winsock1.LocalIP  '"127.0.0.1"   '本机IP地址
   Text2.Text = "192.168.1.5"                    '设置要连接的设备端IP地址 或该计算机名称 "Pc-20160125glrg"
   Text3.Text = "1000"                           '绑定到本服务器的端口上
   Text4.Text = "1001"                           '设备端端口
   With Winsock1
      .RemotePort = Val(Text4.Text)              '设置客户端连接的端口
      .Bind Val(Text3.Text)                      '绑定到本机的端口上。
      .RemoteHost = Text2.Text                   '设置要连接的IP地址
      .LocalPort = Val(Text3.Text)               '设置本机连接的端口
   End With
   'Call Winsock1.Connect("192.168.1.10", "1002") '调用Connect方法,与指定IP地址的计算机进行连接
   Winsock1.Connect
   Winsock1.Listen '开始监听
   'Call ChkLink
   '*****************************
   OldDate = Date$
   LabDate.Caption = Date$
   LabWeek.Caption = GetWeek(Now)
   'Me.Caption = MsgTitle

   '本地路径App.Path处理\后,赋值给变量AppDisk
   AppDisk = IIf(right(App.Path, 1) = "\", App.Path, App.Path & "\")
   Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height - 450) \ 2 '窗体居中
   '****************************** 添加局域网名单
   'Combo1.AddItem "127.0.0.1"
   aa = Getusers
   If InStr(aa, ";") > 0 Then
      S = Split(aa, ";")
      For i = 0 To UBound(S)
         If S(i) <> "" Then Combo1.AddItem S(i)
      Next i
      If Combo1.ListCount > 0 Then Combo1.ListIndex = 0
   End If
   Combo1.Text = Winsock1.LocalHostName
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
   ImageExit(0).Visible = True
   If Button = 1 Then Call DragKj(Me.hwnd)
End Sub

Private Sub Form_Unload(Cancel As Integer)
   On Error Resume Next
   Call SkinH_Detach '释放皮肤资源
   If Winsock1.State <> sckClosed Then Winsock1.Close
   'Winsock1.Listen 关闭连接后继续监听
   Set MainForm = Nothing
   'End
End Sub

Private Sub Combo1_Click()
   Text2.Text = Combo1.Text
End Sub

Private Sub Image1_Click()
   On Error Resume Next
   Winsock1.SendData Chr(3) & TextSend.Text & Chr(5)
   TextSend.Text = ""
End Sub

Private Sub TextSend_KeyPress(KeyAscii As Integer)
   If KeyAscii = 13 Then Image1_Click: KeyAscii = 0
End Sub

Private Sub Timer1_Timer() '定时器1的事件
   On Error Resume Next
   If Date$ <> OldDate Then '如果当前日期不等于旧日期的变量 OldDate
      LabDate.Caption = Format(Date$, "yyyy-mm-dd") '使用format函数以定义的格式填入标签LabDate
      LabWeek.Caption = GetWeek(Now) '调用副程序GetWeek获取今天星期几填入标签LabWeek
      OldDate = Date$ '将今天的日期赋值给旧日期的变量 OldDate
   End If
   LabTime.Caption = Time$ '在标签LabTime上显示当前的时间
   '使用API GetAsyncKeyState 获取键盘是否按下了Esc键 如果按下了Esc键则退出程序
   If GetAsyncKeyState(vbKeyEscape) Then Unload Me '如果按下了Esc键则退出本程序
   If Second(Time) Mod 30 = 0 Then Call CleanMemory '每隔30秒清除一次内存耗用
End Sub

'客户端和服务器端建立连接后,如果接收到新的数据,就会触发Dataarrival事件,在响应这个事件时,使用Getdata方法获得发送来的数据
'MsgBox bytesTotal 接收到的数据长度
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) 'WINSOCK1数据接受事件
   On Error Resume Next
   Winsock1.GetData StrData, vbString '将接收到的数据赋值给变量StrData
   'GetVal = Hex2Dec(Mid(StrData, 7, 8))
   List1.AddItem StrData   'Mid(StrData, 1, 6) & Format(CStr(GetVal), "000.0")
   List1.Selected(List1.ListCount - 1) = True
   '***************************************
   If left(StrData, 1) = Chr(2) Then
      '接收到的数据第一位是起始符Chr(2) 第2-5位是站点号 第8,9位是温度值  第12,13位是湿度值(模拟 要以实际需求为准)
      bb = Mid(StrData, 14, 2)
      cc = Mid(StrData, 18, 2)
      aa = Chr(2) & Text3.Text & "--" & bb & "--" & cc & "--接收数据反馈回设备" & vbCrLf
      Winsock1.SendData aa
      List2.AddItem aa
      List2.Selected(List2.ListCount - 1) = True
      LabVal(0).Caption = bb & "℃"
      LabVal(1).Caption = cc & "%"
   Else
      If left(StrData, 1) = Chr(3) Then TextRcv.Text = StrData
   End If
End Sub

Function ChkLink() As Boolean
   On Error Resume Next
   Dim III&
   ChkLink = False
   'Winsock1.Connect
   III = 0
   Do
     DoEvents
     III = III + 1
     If III > 1000 Then Exit Do
     If Winsock1.State = sckConnected Then
        ChkLink = True: Exit Do
     Else
        If Winsock1.State = sckError Then Exit Do
     End If
     Me.Caption = Winsock1.State
   Loop Until Winsock1.State = sckConnected Or Winsock1.State = sckError
   If Winsock1.State = sckError Then
      'Winsock1.Close
      Me.Caption = "与服务器连接失败"
   Else
      Me.Caption = "已与服务器连接成功"
   End If
End Function

Public Function Hex2Dec(Hstr As String) As Single
   On Error Resume Next
   '***********************************************************************
   '将十六进制转化成十进制浮点数
   '***********************************************************************
   Dim L As Long, f As Single
   L = Val("&H" & Hstr)
   CopyMemory f, L, 4
   Hex2Dec = Format(f, "0.00")
End Function

Private Sub ImageExit_Click(Index As Integer)
   Unload Me
End Sub

Private Sub ImageExit_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
   If Index = 0 Then ImageExit(0).Visible = False
End Sub

Private Sub aicCom_Click(Index As Integer, ByVal Button As Integer)
   Call LabCom_Click(Index)
End Sub

Private Sub LabCom_Click(Index As Integer)
   On Error Resume Next
   Select Case Index
      Case 0  '网页文件下载
         WebDown.Show
         Unload Me
      Case 1 '本机信息
         Call ShowMsg
   End Select
End Sub

Private Sub ShowMsg()
   On Error Resume Next
   Dim UserNm$, CompNm$, MyIP$, Msg$
   CompNm = Environ("computername") '调用Environ方法返回电脑名称 赋值给变量CompNm
   UserNm = Environ("username") '调用Environ方法返回用户名称 赋值给变量CompNm
   MyIP = GetLocalIP '调用副程序GetLocal返回IP 赋值给变量MyIP
   Msg = "本机电脑名称:" & CompNm & vbCrLf
   Msg = Msg & "本机用户名称:" & UserNm & vbCrLf
   Msg = Msg & "本机IP:" & MyIP
   MsgBox Msg
End Sub

Function GetLocalIP() As String '获取本机IP地址的副程序
   On Error Resume Next
   Dim WinIP As Object '定义对象
   Set WinIP = CreateObject("MSWinsock.Winsock") '创建此对象
   GetLocalIP = WinIP.LocalIP '函数返回IP
End Function



'***********************************************************************************************************************
'******************************************* Client 设备端

Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Dim StrData$, jj&, SeqNo&
Private Sub Form_Load()
   On Error Resume Next '在错误处理
   SkinH_Attach '加载皮肤
   SkinH_AttachEx AppDisk & "淡雅流光.she", vbNullString '使用默认风格.she的皮肤
   Call SkinH_SetWindowAlpha(Me.hwnd, 255) '透明度255
   Me.Caption = "设备端"
   Text1.Text = Winsock1.LocalIP '本机IP地址
   Text2.Text = "127.0.0.1"  '设置要连接的服务器IP地址
   Text3.Text = "1001" '绑定到本机的端口上
   Text4.Text = "1000" '服务器端口
   With Winsock1
      .Protocol = sckUDPProtocol
      .RemotePort = Val(Text4.Text)  '设置客户端连接的端口
      .Bind Val(Text3.Text)          '绑定到本机的端口上,UDP不需要绑定, TCP需要
      .RemoteHost = Text2.Text       '设置要连接的IP地址
   End With
   Winsock1.Connect                  '调用Connect方法,与指定IP地址的计算机进行连接
   Winsock1.Listen                   '开始监听
   Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height - 510) \ 2 '窗体居中
   '****************************** 添加局域网名单
   'Combo1.AddItem "127.0.0.1"
   aa = Getusers
   If InStr(aa, ";") > 0 Then
      S = Split(aa, ";")
      For i = 0 To UBound(S)
         If S(i) <> "" Then Combo1.AddItem S(i)
      Next i
      If Combo1.ListCount > 0 Then Combo1.ListIndex = 0
   End If
   '**********************************************
   LabDate.Caption = Date$
   LabWeek.Caption = GetWeek(Now)
   OldDate = Date$
End Sub

Private Sub Form_Unload(Cancel As Integer)
   On Error Resume Next
   Call SkinH_Detach '释放皮肤资源
   If Winsock1.State <> sckClosed Then Winsock1.Close
   Set MainForm = Nothing
   'End
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
   ImageExit(0).Visible = True
   If Button = 1 Then Call DragKj(Me.hwnd)
End Sub

Private Sub ImageExit_Click(Index As Integer)
   Unload Me
End Sub

Private Sub ImageExit_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
   If Index = 0 Then ImageExit(0).Visible = False
End Sub

Private Sub Combo1_Click()
   Text2.Text = Combo1.Text
End Sub

Private Sub Image1_Click()
   On Error Resume Next
   Winsock1.SendData Chr(3) & TextSend.Text & Chr(5)
   TextSend.Text = ""
End Sub

Private Sub ImgStart_Click(Index As Integer, ByVal Button As Integer)
   If Index = 0 Then
      Timer2.Enabled = True
      ImgStart(0).Visible = False
      LabStop.Caption = "停 止"
   Else
      Timer2.Enabled = False
      ImgStart(0).Visible = True
      LabStop.Caption = "启 动"
   End If
End Sub

Private Sub TextSend_KeyPress(KeyAscii As Integer)
   If KeyAscii = 13 Then Image1_Click: KeyAscii = 0
End Sub

Private Sub Timer1_Timer() '定时器1的事件
   On Error Resume Next
   If Date$ <> OldDate Then '如果当前日期不等于旧日期的变量 OldDate
      LabDate.Caption = Format(Date$, "yyyy-mm-dd") '使用format函数以定义的格式填入标签LabDate
      LabWeek.Caption = GetWeek(Now) '调用副程序GetWeek获取今天星期几填入标签LabWeek
      OldDate = Date$ '将今天的日期赋值给旧日期的变量 OldDate
   End If
   LabTime.Caption = Time$ '在标签LabTime上显示当前的时间
   '使用API GetAsyncKeyState 获取键盘是否按下了Esc键 如果按下了Esc键则退出程序
   If GetAsyncKeyState(vbKeyEscape) Then Unload Me
End Sub

Private Sub Timer2_Timer()
   On Error Resume Next
   '温度介于20-60度随机,湿度介于RH 30-80%随机
   LabVal(0).Caption = CStr(Int(Rnd * 41) + 20)
   LabVal(1).Caption = CStr(Int(Rnd * 51) + 30)
   aa = Text3.Text & "--" & Format(CStr(SeqNo), "0000") & "--" & LabVal(0).Caption & "--" & LabVal(1).Caption
   Winsock1.SendData Chr(2) & aa & vbCrLf
   List1.AddItem aa
   List1.Selected(List1.ListCount - 1) = True
   SeqNo = IIf(SeqNo + 1 >= 10000, 1, SeqNo + 1)
End Sub

'客户端和服务器端建立连接后,如果接收到新的数据,就会触发Dataarrival事件,在响应这个事件时,使用Getdata方法获得发送来的数据
'MsgBox bytesTotal 接收到的数据长度
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) 'WINSOCK1数据接受事件
   On Error Resume Next
   Winsock1.GetData StrData, vbString '将接收到的数据赋值给变量StrData
   If left(StrData, 1) = Chr(2) Then
      List2.AddItem StrData
      List2.Selected(List2.ListCount - 1) = True
   Else
      If left(StrData, 1) = Chr(3) Then TextRcv.Text = StrData
   End If
End Sub




WinSock_Test.rar

3.87 MB, 下载次数: 169

回复

使用道具 举报

0

主题

2

帖子

1016

积分

游客

Rank: 1

积分
1016
发表于 2020-7-30 10:20:36 | 显示全部楼层
没有权限下载附件
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|Archiver|手机版|小黑屋|菜鳥编程园地 ( 蜀ICP备20021315号-1 )

GMT+8, 2022-9-27 15:24 , Processed in 0.158371 second(s), 25 queries .

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表