精华内容
下载资源
问答
  • 代码包含服务器和客户端的通讯以及交流,简单明了,容易看懂
  • VB网络数据库编程服务器客户端

    热门讨论 2013-10-19 12:16:08
    VB网络数据库编程服务器客户端源代码,包括ODBC.bas,Recordsets.bas,UserMod.bas
  • VB开发的TCP通信示例,包括服务端和客户端VB开发的TCP通信示例,包括服务端和客户端VB开发的TCP通信示例,包括服务端和客户端VB开发的TCP通信示例,包括服务端和客户端
  • vb.net服务端和客户端的通信实例原码,实测可用,适合入门学习
  • vb.net下的MQTT服务器客户端,包含启动与关闭服务、连接与断开连接、发布与订阅等全部功能,对于用vb.net开发MQTT相关功能的需求有很大的帮助
  • VB.net TCP传输 客户端

    2018-07-19 11:47:38
    VB.net TCP传输 客户端 如果版本不兼容,复制代码过去。
  • VB中一个服务器和多个客户端的程序

    千次阅读 2014-10-15 08:23:07
    服务器端 Private Sub Command1_Click() Dim strSend As String strSend = Text2.Text Sock(1).SendData strSend End Sub Private Sub Command2_Click() Command2.Caption = Sock(0)....

    具体的理论只是,参考  点击打开链接的上一部分

    服务器端


    Private Sub Command1_Click()
    Dim strSend As String
    strSend = Text2.Text
    Sock(1).SendData strSend
    End Sub


    Private Sub Command2_Click()
    Command2.Caption = Sock(0).RemoteHostIP


    End Sub


    Private Sub Form_Load()
    'Load Sock(0)
    Listener.LocalPort = 8000   '端口号
    Listener.Listen             '开始侦听
    End Sub


    Private Sub Listener_ConnectionRequest(ByVal requestID As Long)
    Dim SockIndex As Integer: SockIndex = 200
      
    Dim i As Integer
      
    '遍历控件
    For i = 0 To Sock.UBound
        If Sock(i).State = 0 Then SockIndex = i
    Next
      
    If SockIndex = 200 Then
        Load Sock(Sock.UBound + 1)
        SockIndex = Sock.UBound
    End If
      
    '接受请求
    Sock(SockIndex).Accept (requestID)
    End Sub


    Private Sub Sock_Close(Index As Integer)
    If Sock(Index).State <> sckClosed Then
     Sock(Index).Close
    End Sub


    Private Sub Sock_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    Dim strGet As String
      
    '接收字符串并写入text中
    Sock(Index).GetData strGet
    Text1.Text = strGet
    End Sub


    客户端


    Private Sub Command1_Click()
    Dim strSet As String
    strSet = Text2.Text
    Winsock1.SendData strSet
    End Sub


    Private Sub Command2_Click()
    Me.Winsock1.RemoteHost = "10.1.51.150"
    Me.Winsock1.RemotePort = 8000
    Me.Winsock1.Connect
    End Sub


    Private Sub Form_Load()


    End Sub


    Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim strGet As String
      
    '接收字符串并写入Text1控件中
    Winsock1.GetData strGet
    Text1.Text = strGet
    End Sub

    展开全文
  • access服务器和客户端源码,客户端可以发送查询给服务器服务器把查询的结果发给客户端。不懂的MM我。
  • vb.net Socket服务端支持多客户端连接,并且实时监控客户端是否断开连接,代码注释明了,初学者很容易看得懂
  • 摘要:VB源码,网络相关,TELNET 基于VB的TELNET服务器客户端程序,仅用于说明TELNET服务器的原理,并支持一些常用的Telnet命令,API声明,用来使程序暂停执行以模拟实际中的延迟。
  • vb。net编写的局域网 服务器客户端通讯,采用了vb。net,在vs2010下调试通过,直接将代码拷贝到。net窗体里面,补上相应的控件即可
  • 实现 UDP 的连接通行,包括 client server
  • 内容索引:VB源码,网络相关,聊天,客户端 VB C/S网络聊天服务器客户端源程序,一个点对点实现的Vb聊天程序,分别展示了服务端和客户端编程的实现,简单实用。两程序在VB6下均可直接编译,在程序中添加聊天模块的话...
  • VB Winsock实现客户端连接服务端登录示例
  • 利用VB语言编写出一个OPC客户端程序,实现客户端能够读取服务器中的数据,并 把读取到的数据通过棒柱文本框显示,还可以保存数据便于查找,同时应用了Picture控件对实时数据变化趋势分析。还可以配置DCOM,使...
  • 实现 tcp 的通信,包括 client server
  • 最近做MQTT发布订阅的功能,在网上找了很久,都是C#或其它语言的,vb.net的基本找不到,所以用vb.net做了个MQTT客户端的发布订阅功能,不包含服务器代码。 要测试使用该代码,需要有自己的MQTT服务器
  • VB 做的FTP工具,服务器客户端,源码VB
  • vb编写websocket客户端示例(每秒百万弹幕吞吐量) ​​​​​​​文章上方有详细的规范、源码链接,你有任何问题可以联系我:邮箱:952125505@qq.com ,QQ交流群:715895604 根据前面两节讲解,我们了解了...

    《websocket协议详解》教程分三篇:

    1.  什么是websocket
    2. websocket协议规范
    3.  用vb编写websocket客户端示例(每秒百万弹幕吞吐量)

    ​​​​​​​文章上方有详细的规范、源码链接,你有任何问题可以联系我:邮箱:952125505@qq.com ,QQ交流群:715895604


    根据前面两节讲解,我们了解了websocket是做什么,并详细的了解了websocket的协议规范,下面我们就用vb制作一个websocket控件。 

    首先打开vb,建立一个自定义控件,命名为WebSock

    Option Explicit
    
    '★─☆─★─☆─★─☆─★─☆─★─☆─★─☆─★─☆─★─☆─★─☆─★                                  。。
    '│                              。。。。                                │
    '☆                             。。  。。                               ☆
    '│                            。。     。。                             │
    '★                           。。       。。                            ★
    '│                          。。         。。                           │
    '☆                         。。           。。                          ☆
    '│                        。。     OOO     。。                         │
    '★                       。。    QQQQQQQ    。。                        ★
    '│                      。。   88888888888   。。                       │
    '☆                     。。    8   。    8    。。                      ☆
    '│                    。。     H -    -  H     。。 .                   │
    '★                    。。    0│       │0    。。                     ★
    '│                    。。     │ ╰-╯ │     。。 .                   │
    '☆                    。。     ╰-------╯     。。 .                   ☆
    '│                     。。       。。。      。。 .                    │
    '★                       。。╭           ╮。。 .                      ★
    '│                         ╭ ╰         ╯ ╮ .                        │
    '☆                        ╭  ╰         ╯  ╮ .                       ☆
    '│                       ╭     ╰      ╯    ╮ .                      │
    '★                      (         ╰ v╯        ) .                     ★
    '│                        ╭                 ╮ .                       │
    '☆                      ╭                      ╮ .                    ☆
    '│                     (                          ) .                   │
    '★                   (。)(。)(。)(。)(。)(。)(。)(。) .                 ★
    '│                 (。)(。)(。)(。)(。)(。)(。)(。)(。) .               │
    '☆                [0][0][0][0][0][0][0][0][0][0][0][0][0] .             ☆
    '│                [0][0][0][0][0][0][0][0][0][0][0][0][0]               │
    '★                                                               .      ★
    '│       *******************************************************        │
    '☆                          佛祖保佑   永无BUG                          ☆
    '│                                                                      │
    '★─☆─★─☆─★─☆─★─☆─★─☆─★─☆─★─☆─★─☆─★─☆─★
    '****************************************************************************************
    
    '* 模块名称: 二郎websocket完美客户端
    
    '* 功能描述:
    
    '****************************************************************************************
    '创建:2019-09-01;作 者:二郎666 QQ:952125505;版本:Version 1.0.1(2019-09-01)                                                                                                                                            .                                                                                                                                                          .
    
    
    
    '连接参数
    Private Type urlType
    
        url As String
    
        Proc As String
        
        Host As String
        
        Port As String
        
        Path As String
        
        Header As String
        
        wsKey As String
        
        Accept As String
        
    End Type
    
    '基本帧协议
    Private Type abnfType
        
        FIN As Boolean
        
        RSV1 As Boolean
        
        RSV2 As Boolean
        
        RSV3 As Boolean
        
        OPCode As Long
        
        FrameCode As Long
        
        MaskBool As Boolean
        
        MaskKey() As Byte
        
        DataLenL As Long
        
        DataLenS As Long
          
        DataStart As Long
        
        DataByte() As Byte
        
        ALen As Long
        
    End Type
    
    'websocket状态
    Enum stateEnum
    
        off = 0
        
        onConnect = 1
        
        Busy = 2
    
    End Enum
    
    
    Enum opcodeEnum
    
        opContin = 0
        
        opText = 1
        
        opBinary = 2
        
        '3 - 7 非控制帧保留
        
        opclose = 8
        
        opping = 9
        
        oppong = 10
        
        '11-15 控制帧保留
        
    End Enum
    
    Public Enum opMsgenum
    
        msgContin = 0
        
        msgtext = 1
        
        msgBinary = 2
        
    End Enum
    
    Private Declare Function timeGetTime Lib "winmm.dll" () As Long
     
    Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
     
    'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
     
    Private Const CP_UTF8 = 65001
    Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
    Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
     
    Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long
     
    Private Declare Function send Lib "ws2_32.DLL" (ByVal socket As Long, Buf As Any, ByVal buflen As Long, ByVal Flags As Long) As Long
    
    Private Const wsGUID = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
    
    Private SendUrl As urlType
    
    Private OPCode As opcodeEnum
    
    Private ABNF As abnfType
    
    Dim isConnect As Boolean
    
    
    '缺省属性值:
    Private Const m_def_State = 0
    
    '属性变量:
    Dim m_State As stateEnum
    
    '事件声明:
    Event OnMessage(ByVal RecvData As Variant, ByVal GetMsg As Long, sFIN As Boolean)
    
    Event OnOpen()
    
    Event OnClose()
    
    Event SendComplete()
    
    Event OnError(Number As Long, Str As String)
    '
    '
    '
    '
    Public Sub Connect(ByVal url As String)
        
        m_State = onConnect
        
        If Winsock1.State <> 0 Then
            
            Winsock1.Close
            
            Sleep2 10
            
        End If
        
        SendUrl = jiexiUrl(url)
        
        Winsock1.Connect SendUrl.Host, SendUrl.Port
        '
    End Sub
    
    
    
    Private Sub Winsock1_Connect()
        
        isConnect = True
        
        Call GetHeaders
        
        Winsock1.SendData (SendUrl.Header)
        
    End Sub
    
    Private Sub Winsock1_SendComplete()
        
        RaiseEvent SendComplete
        
        If m_State = Busy Then m_State = onConnect
        
    End Sub
    
    
    Public Sub OnClose()
        
        Dim B(1) As Byte, tempStart As String
        
        m_State = Busy
        
        B(0) = &H88
        
        B(1) = &H0
        
        send Winsock1.SocketHandle, B(0), 2, 0
        
        If Winsock1.State <> 0 Then
            
            Winsock1.Close
            
            Sleep2 10
            
        End If
        
        m_State = off
        
        RaiseEvent OnClose
        
    End Sub
    
    Private Sub Winsock1_Close()
        
        m_State = off
        
        RaiseEvent OnClose
        
    End Sub
    
    
    Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
        
        RaiseEvent OnError(3000, "Winsock错误描述:" & Description)
        
    End Sub
    
    
    
    
    
    '注意!不要删除或修改下列被注释的行!
    'MemberInfo=22,1,1,0
    Public Property Get State() As stateEnum
        State = m_State
    End Property
    
    '注意!不要删除或修改下列被注释的行!
    'MappingInfo=Winsock1,Winsock1,-1,LocalHostName
    Public Property Get LocalHostName() As String
        LocalHostName = Winsock1.LocalHostName
    End Property
    
    '注意!不要删除或修改下列被注释的行!
    'MappingInfo=Winsock1,Winsock1,-1,LocalIP
    Public Property Get LocalIP() As String
        LocalIP = Winsock1.LocalIP
    End Property
    
    '注意!不要删除或修改下列被注释的行!
    'MappingInfo=Winsock1,Winsock1,-1,LocalPort
    Public Property Get LocalPort() As Long
        LocalPort = Winsock1.LocalPort
    End Property
    
    Public Property Let LocalPort(ByVal New_LocalPort As Long)
        Winsock1.LocalPort() = New_LocalPort
        PropertyChanged "LocalPort"
    End Property
    
    '为用户控件初始化属性
    Private Sub UserControl_InitProperties()
        
        m_State = m_def_State
        
        SendUrl.wsKey = Base64Encode(RandB(16))
        
        
    End Sub
    '从存贮器中加载属性值
    Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
        Winsock1.LocalPort = PropBag.ReadProperty("LocalPort", 0)
    End Sub
    '将属性值写到存储器
    Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
        Call PropBag.WriteProperty("LocalPort", Winsock1.LocalPort, 0)
    End Sub
    Public Sub SendData(ByRef SendMsg As Variant, Optional opMsg As Long, Optional FinB As Boolean = True) '/byt数组么
        
        Dim I As Long, L As Long, byt1() As Byte, byt2() As Byte, Byt3() As Byte, S As String, tempB() As Byte, ABMaskKey() As Byte
        
        If TypeName(SendMsg) = "Byte()" Then
            
            If opMsg = msgtext Then
                
                RaiseEvent OnError(3009, "sendMsg与opMsg冲突")
                
                Exit Sub
                
            End If
            
            tempB = SendMsg
            
        Else
            
            If opMsg = msgBinary Then
                
                RaiseEvent OnError(3009, "sendMsg与opMsg冲突")
                
                Exit Sub
                
            End If
            
            tempB = UTF8Encode(CStr(SendMsg))
            
        End If
        
        If SafeArrayGetDim(tempB) <= 0 Then
            
            RaiseEvent OnError(3001, "没检测到发送数据")
            
            Exit Sub
            
        End If
        
        ABMaskKey = RandB(4)
        
        AddMask tempB, ABMaskKey
        
        m_State = Busy
        
        L = UBound(tempB) + 1
        
        If L < 126 Then
            
            ReDim byt1(L + 5)
            
            byt1(0) = &H80 Xor CByte(opMsg)
            
            byt1(1) = CByte(L) Xor &H80
            
            CopyMemory byt1(2), ABMaskKey(0), 4
            
            CopyMemory byt1(6), tempB(0), L
            
        ElseIf L >= 126 And L <= 65535 Then
            
            ReDim byt1(L + 7)
            
            byt1(0) = &H80 Xor CByte(opMsg)
            
            byt1(1) = &HFE
            
            S = Right("0000" & Hex(L), 4)
            
            byt1(2) = CLng("&h" & Left(S, 2))
            
            byt1(3) = CLng("&h" & Right(S, 2))
            
            CopyMemory byt1(4), ABMaskKey(0), 4
            
            CopyMemory byt1(8), tempB(0), L
            
        ElseIf Str(L) > 65535 Then
            
            RaiseEvent OnError(3002, "发送数据长度超过限制,>65535")
            
            m_State = onConnect
            
            Exit Sub
            
        End If
        
        send Winsock1.SocketHandle, byt1(0), UBound(byt1) + 1, 0
        
        m_State = onConnect
        
    End Sub
    
    Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
        
        Dim GetMsg() As Byte, S1 As String, S2 As String, S3 As String, I As Long
        
        Static GetData() As Byte
        
        Static ALen As Long
        
        Winsock1.GetData GetMsg, vbByte
        
        
        If isConnect = True Then
            
            S1 = "HTTP/1.1 101"
            
            S2 = ToUnicodeStr(GetMsg)
            
            If InStr(S2, S1) > 0 Then
                
                isConnect = False
                
                SendUrl.Accept = BASE64SHA1(SendUrl.wsKey & wsGUID, True)
                
                S3 = MidStr(S2, "Sec-WebSocket-Accept:", Chr(13) & Chr(10))
                
                If Trim(S3) <> SendUrl.Accept Then
                    
                    RaiseEvent OnError(3003, "服务器未通过客户端验证,返回:" & S2)
                    
                End If
                
                m_State = onConnect
                
                ALen = 0
                
                RaiseEvent OnOpen
                
                'Call sendPong(20)
            Else
                
                RaiseEvent OnError(3004, "连接握手错误:" & S2)
                
                Call OnClose
                
            End If
            
            Exit Sub
            
        End If
        
        
    AA:
        
        If ALen = 0 Then
            
            Call SSRP_ABNF(GetMsg)
            
            Erase GetData
            
            GetData = GetMsg
            
            ALen = UBound(GetMsg) + 1
            
        Else
            
            ReDim Preserve GetData(ALen + UBound(GetMsg))
            
            CopyMemory GetData(ALen), GetMsg(0), UBound(GetMsg) + 1
            
            ALen = ALen + UBound(GetMsg) + 1
            
        End If
        
        If ALen < ABNF.ALen Then Exit Sub
        
        If ABNF.DataLenL > 0 Then
            
            ReDim Preserve ABNF.DataByte(ABNF.DataLenL - 1)
            
            CopyMemory ABNF.DataByte(0), GetData(ABNF.DataStart), ABNF.DataLenL
            
        End If
        
        
        Select Case ABNF.OPCode
            
        Case 8
            
            RaiseEvent OnError(3005, "服务器关闭连接,关闭代码:" & ToUnicodeStr(ABNF.DataByte))
            
            Call OnClose
            
            Exit Sub
            
        Case 9
            
            Dim P() As Byte
            
            ReDim Preserve P(6 + ABNF.DataLenL - 1)
            
            P(0) = &H8A
            
            P(1) = (CByte(ABNF.DataLenL) Or &H80)
            
            Dim ABMaskKey() As Byte
            
            ABMaskKey = RandB(4)
            
            CopyMemory P(2), ABMaskKey(0), 4
            
            If ABNF.DataLenL > 0 Then
                
                AddMask ABNF.DataByte, ABMaskKey
                
                CopyMemory P(6), ABNF.DataByte(0), ABNF.DataLenL
                
            End If
            
            send Winsock1.SocketHandle, P(0), UBound(P) + 1, 0
            
            
        Case 10
            
            
        Case Else
            
            If ABNF.DataLenL > 0 Then
                
                If ABNF.FrameCode = 1 Then
                    
                    RaiseEvent OnMessage(ToUnicodeStr(ABNF.DataByte), ABNF.FrameCode, ABNF.FIN)
                    
                Else
                    
                    RaiseEvent OnMessage(ABNF.DataByte, ABNF.FrameCode, ABNF.FIN)
                    
                End If
                
            End If
            
        End Select
        
        If ABNF.DataLenL > 0 Then Erase ABNF.DataByte
        
        ALen = ALen - ABNF.ALen
        
        If ALen > 0 Then
            
            ReDim Preserve GetMsg(ALen - 1)
            
            CopyMemory GetMsg(0), GetData(ABNF.ALen), ALen
            
            ALen = 0
            
            GoTo AA
            
        End If
        
        ALen = 0
        
    End Sub
    
    Private Sub SSRP_ABNF(Byt() As Byte)
        
        Dim I As Long, L As Integer
        
        ABNF.FIN = IIf((Byt(0) And &H80) = &H80, True, False)
        
        ABNF.RSV1 = IIf((Byt(0) And &H40) = &H40, True, False)
        
        ABNF.RSV2 = IIf((Byt(0) And &H20) = &H20, True, False)
        
        ABNF.RSV3 = IIf((Byt(0) And &H10) = &H10, True, False)
        
        ABNF.OPCode = Byt(0) And &H7F
        
        If ABNF.OPCode > 0 And ABNF.OPCode <> 8 And ABNF.OPCode <> 9 And ABNF.OPCode <> 10 Then ABNF.FrameCode = CLng(ABNF.OPCode)
        
        If UBound(Byt) < 1 Then
            
            ABNF.DataStart = 0
            
            ABNF.DataLenL = 0
            
            ABNF.MaskBool = False
            
            Exit Sub
            
        End If
        
        ABNF.MaskBool = IIf((Byt(1) And &H80) = &H80, True, False)
        
        
        L = Byt(1) And &H7F
        
        If ABNF.MaskBool = False Then
            
            If L < 126 Then
                
                ABNF.DataLenL = L
                
                ABNF.DataStart = 2
                
                ABNF.ALen = ABNF.DataStart + ABNF.DataLenL
                
            ElseIf L = 126 Then
                
                If UBound(Byt) >= 3 Then
                    
                    ABNF.DataLenL = (Byt(2) * &H100) + Byt(3)
                    
                Else
                    
                    ABNF.DataLenL = (Byt(2) * &H100)
                    
                End If
                
                ABNF.DataStart = 4
                
                ABNF.ALen = ABNF.DataStart + ABNF.DataLenL
                
            ElseIf L = 127 Then
                
                ABNF.DataLenL = -1
                
                ABNF.DataStart = 10
                
                Dim HexN As String
                
                For I = 2 To 9
                    
                    If UBound(Byt) >= I Then
                        
                        HexN = HexN & Right("00" & Hex(Byt(I)), 2)
                        
                    Else
                        
                        Exit Sub
                        
                    End If
                    
                Next
                
                ABNF.ALen = -1
                
                ABNF.DataLenS = Hex2Dec(HexN)
                
            End If
            
        End If
        
        
    End Sub
    
    
    
    Private Sub sendPong(t As Long)
        
        Dim TimerNum As Long, P(5) As Byte
        
        P(0) = &H8A
        
        P(1) = &H80
        
        Dim ABMaskKey() As Byte
        
        ABMaskKey = RandB(4)
        
        CopyMemory P(2), ABMaskKey(0), 4
        
        On Error Resume Next
        
        Do Until Winsock1.State = 0
            
            TimerNum = TimerNum + 1
            
            Sleep2 10
            
            If TimerNum >= t Then
                
                send Winsock1.SocketHandle, P(0), 6, 0
                
                TimerNum = 0
                
            End If
            
            Sleep2 (1000)
            
        Loop
        
    End Sub
    
    
    
    Private Sub AddMask(DataB() As Byte, TKey() As Byte)
        Dim I As Long
        
        For I = 0 To UBound(DataB)
            
            DataB(I) = DataB(I) Xor TKey(I Mod 4)
            
        Next
        
        'AddMask = DataB
        
    End Sub
    
     
    Private Function MidStr(Str1 As String, S1 As String, S2 As String) As String
        
        Dim N1 As Long, N2 As Long
        
        On Error Resume Next
        
        N1 = InStrB(Str1, S1) + LenB(S1)
        
        N2 = InStrB(N1, Str1, S2)
        
        MidStr = MidB(Str1, N1, N2 - N1)
        
        If Err <> 0 Then
            
            MidStr = ""
            
            Err.Clear
            
            Debug.Print "截取字符串失败:" & S1 & vbCrLf & Str1
            
        End If
        
    End Function
    
    
    Private Function RandB(N As Long) As Byte()
        
        Dim I As Long, tempB() As Byte
        
        ReDim tempB(N - 1)
        
        Randomize
        
        For I = 0 To N - 1
            
            tempB(I) = CByte(Rnd * 127 + 1)
            
        Next
        
        RandB = tempB
        
    End Function
    
     
    Private Function Sleep2(t As Long)
        
        Dim Savetime As Long
        
        Savetime = timeGetTime
        
        While timeGetTime < Savetime + t
            
            DoEvents
            
        Wend
        
    End Function
    
     
    Public Function BASE64SHA1(ByVal sTextToHash As String, Optional IsB64 As Boolean = False)
        
        Dim Asc As Object, Enc As Object, TextToHash() As Byte, SharedSecretKey() As Byte, ByteS() As Byte
        
        Const cutoff As Integer = 5
        
        Set Asc = CreateObject("System.Text.UTF8Encoding")
        
        'Set enc = CreateObject("System.Security.Cryptography.HMACSHA1")
        
        Set Enc = CreateObject("System.Security.Cryptography.SHA1Managed")
        
        TextToHash = Asc.Getbytes_4(sTextToHash)
        
        'SharedSecretKey = asc.GetBytes_4(sTextToHash)
        
        'enc.Key = SharedSecretKey
        
        ByteS = Enc.ComputeHash_2((TextToHash))
        
        If IsB64 = True Then
            
            BASE64SHA1 = Base64Encode(ByteS)
            
        Else
            
            BASE64SHA1 = CStr(ByteS)                                                '//
            
        End If
        
        Set Asc = Nothing
        
        Set Enc = Nothing
        
    End Function
    
    
    
    Private Function Base64Encode(Str() As Byte) As String
        
        On Error Resume Next
        
        Dim Buf() As Byte, length As Long, mods As Long, TempS As String
        
        Const B64_CHAR_DICT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
        
        mods = (UBound(Str) + 1) Mod 3
        
        length = UBound(Str) + 1 - mods
        
        ReDim Preserve Buf(length / 3 * 4 + IIf(mods <> 0, 4, 0) - 1)
        
        Dim I As Long
        
        For I = 0 To length - 1 Step 3
            
            Buf(I / 3 * 4) = (Str(I) And &HFC) / &H4
            
            Buf(I / 3 * 4 + 1) = (Str(I) And &H3) * &H10 + (Str(I + 1) And &HF0) / &H10
            
            Buf(I / 3 * 4 + 2) = (Str(I + 1) And &HF) * &H4 + (Str(I + 2) And &HC0) / &H40
            
            Buf(I / 3 * 4 + 3) = Str(I + 2) And &H3F
            
        Next
        
        If mods = 1 Then
            
            Buf(length / 3 * 4) = (Str(length) And &HFC) / &H4
            
            Buf(length / 3 * 4 + 1) = (Str(length) And &H3) * &H10
            
            Buf(length / 3 * 4 + 2) = 64
            
            Buf(length / 3 * 4 + 3) = 64
            
        ElseIf mods = 2 Then
            
            Buf(length / 3 * 4) = (Str(length) And &HFC) / &H4
            
            Buf(length / 3 * 4 + 1) = (Str(length) And &H3) * &H10 + (Str(length + 1) And &HF0) / &H10
            
            Buf(length / 3 * 4 + 2) = (Str(length + 1) And &HF) * &H4
            
            Buf(length / 3 * 4 + 3) = 64
            
        End If
        
        For I = 0 To UBound(Buf)
            
            TempS = TempS + Mid(B64_CHAR_DICT, Buf(I) + 1, 1)
            
        Next
        
        Base64Encode = TempS
        
        
    End Function
    
    Private Function Hex2Dec(H As String) As String
        
        Dim a As Long, C As Long
        
        Dim I As Long, N As Long
        
        Dim j As Long, K As Long
        
        H = Kill0(H)
        
        N = (Len(H) - 1) \ 4 + 1
        
        ReDim B(N) As Long
        
        ReDim d(Int(N * 1.20412 + 1)) As Long
        '
        j = Len(H) + 1
        
        For I = 1 To N
            
            j = j - 4
            
            If j < 1 Then
                
                B(I) = Val("&H" + Mid(H, 1, 3 + j))
                
            Else
                
                B(I) = Val("&H" + Mid(H, j, 4) + "&")
                
            End If
            
        Next I
        '
        j = N: K = 0
        
        Do Until j = 0
            
            C = 0
            
            For I = j To 1 Step -1
                
                a = C * 65536 + B(I)
                
                B(I) = a \ 10000
                
                C = a Mod 10000
                
            Next I
            
            d(K) = C: K = K + 1
            
            If B(j) = 0 Then j = j - 1
            
        Loop
        
        K = K - 1
        
        ReDim Preserve d(K)
        '
        Hex2Dec = CStr(d(K))
        
        For I = K - 1 To 0 Step -1
            
            Hex2Dec = Hex2Dec + Right("000" + CStr(d(I)), 4)
            
        Next I
        
    End Function
    
    
    Private Function ToUnicodeByt(ByRef Utf() As Byte) As Byte()
        
        Dim lret As Long, lLength As Long, lBufferSize As Long, BT() As Byte
        
        lLength = UBound(Utf) + 1
        
        If lLength <= 0 Then Exit Function
        
        lBufferSize = lLength * 2 - 1
        
        ReDim Preserve BT(lBufferSize)
        
        lret = MultiByteToWideChar(CP_UTF8, 0, VarPtr(Utf(0)), lLength, VarPtr(BT(0)), lBufferSize + 1)
        
        If lret <> 0 Then
            
            ReDim Preserve BT(lret - 1)
            
            ToUnicodeByt = BT
            
        End If
        
    End Function
    
     
    Private Function ToUnicodeStr(ByRef Utf() As Byte) As String
        
        Dim lret As Long, lLength As Long, lBufferSize As Long
        
        On Error GoTo errline:
        
        lLength = UBound(Utf) + 1
        
        If lLength <= 0 Then Exit Function
        
        lBufferSize = lLength * 2
        
        ToUnicodeStr = String$(lBufferSize, Chr(0))
        
        lret = MultiByteToWideChar(CP_UTF8, 0, VarPtr(Utf(0)), lLength, StrPtr(ToUnicodeStr), lBufferSize)
        
        If lret <> 0 Then
            
            ToUnicodeStr = Left(ToUnicodeStr, lret)
            
        End If
        
        Exit Function
        
    errline:
        
        ToUnicodeStr = ""
        
    End Function
     
    Private Function UTF8Encode(ByVal strUnicode As String, Optional ByVal CodePage As Long = 65001) As Byte()
        
        Dim TLen As Long, lngBufferSize As Long, lngResult As Long, Arr() As Byte, I As Integer
        
        TLen = Len(strUnicode)
        
        If TLen = 0 Then Exit Function
        
        lngBufferSize = TLen * 3 + 1
        
        ReDim Arr(lngBufferSize - 1)
        
        lngResult = WideCharToMultiByte(CodePage, 0, StrPtr(strUnicode), TLen, Arr(0), lngBufferSize, vbNullString, 0)
        
        If lngResult Then
            
            lngResult = lngResult - 1
            
            ReDim Preserve Arr(lngResult)
            
            UTF8Encode = Arr
            
        End If
        
    End Function
    
    Private Function Url编码(url As String) As String
        
        Dim obj As Object, Code As String, S As String
        
        Dim TValue As String
        
        url = Replace(Replace(Replace(Replace(Replace(Replace(Replace(url, "\", "\\"), """", "\"""), Chr(8), "\b"), Chr(12), "\f"), Chr(10), "\n"), Chr(13), "\r"), Chr(9), "\t")
        
        Code = "function urlbm(s){ return encodeURI(s);}" & "urlbm('" & url & "');"
        
      
        Set obj = CreateObject("MSScriptControl.ScriptControl")
        
        obj.Language = "JavaScript"
        
        S = obj.Eval(Code)
        
        Url编码 = S
        
        Set obj = Nothing
        
    End Function
     
    Private Function IsUTF8(ByteS() As Byte) As Boolean
        
        On Error GoTo CuoWu
        
        Dim I As Long, AscN As Long, length As Long
        
        length = UBound(ByteS) + 1
        
        If length < 3 Then
            
            IsUTF8 = False
            
            Exit Function
            
        ElseIf ByteS(0) = &HEF And ByteS(1) = &HBB And ByteS(2) = &HBF Then
            
            IsUTF8 = True
            
            Exit Function
            
        End If
        
        Do While I <= length - 1
            
            If ByteS(I) < 128 Then
                
                I = I + 1
                
                AscN = AscN + 1
                
            ElseIf (ByteS(I) And &HE0) = &HC0 And (ByteS(I + 1) And &HC0) = &H80 Then
                
                I = I + 2
                
            ElseIf I + 2 < length Then
                
                If (ByteS(I) And &HF0) = &HE0 And (ByteS(I + 1) And &HC0) = &H80 And (ByteS(I + 2) And &HC0) = &H80 Then
                    
                    I = I + 3
                Else
                    
                    IsUTF8 = False
                    
                    Exit Function
                    
                End If
                
            Else
                IsUTF8 = False
                
                Exit Function
                
            End If
            
        Loop
        
        If AscN = length Then
            
            IsUTF8 = False
            
        Else
            
            IsUTF8 = True
            
        End If
        
        Exit Function
        
    CuoWu:
        
        IsUTF8 = False
        
    End Function
    
    
    
    
    
    
    Private Function GetErr(Num As Long) As String
        
        Dim S As String
        
        Select Case Num
            
        Case 1000
            
            S = "正常关闭; 无论为何目的而创建, 该链接都已成功完成任务"
            
        Case 1001
            
            S = "终端离开, 可能因为服务端错误, 也可能因为浏览器正从打开连接的页面跳转离开"
            
        Case 1002
            
            S = "由于协议错误而中断连接"
            
        Case 1003
            
            S = "由于接收到不允许的数据类型而断开连接 (如仅接收文本数据的终端接收到了二进制数据)。"
            
        Case 1004
            
            S = "保留。 其意义可能会在未来定义。"
            
        Case 1005
            
            S = "保留。 表示没有收到预期的状态码。"
            
        Case 1006
            
            S = "保留。 用于期望收到状态码时连接非正常关闭 (也就是说, 没有发送关闭帧)。"
            
        Case 1007
            
            S = "由于收到了格式不符的数据而断开连接 (如文本消息中包含了非 UTF-8 数据)。"
            
        Case 1008
            
            S = "由于收到不符合约定的数据而断开连接。 这是一个通用状态码, 用于不适合使用 1003 和 1009 状态码的场景。"
            
        Case 1009
            
            S = "由于收到过大的数据帧而断开连接"
            
        Case 1010
            
            S = "客户端由于遇到没有预料的情况阻止其完成请求, 因此服务端断开连接。"
            
        Case 1012
            
            S = "服务器由于重启而断开连接。"
            
        Case 1013
            
            S = "服务器由于临时原因断开连接, 如服务器过载因此断开一部分客户端连接。"
            
        Case 1014
            
            S = "标准保留以便未来使用。"
            
        Case 1015
            
            S = "保留。 表示连接由于无法完成 TLS 握手而关闭 (例如无法验证服务器证书)。"
            
        End Select
        
        GetErr = S
        
    End Function
    
    
    Private Function jiexiUrl(url As String) As urlType
        
        Dim RegExp As Object, tempUrl As String
        tempUrl = url
        tempUrl = Replace(tempUrl, "/#", "%23")
        If Not (LCase(tempUrl) Like "wss://*" Or LCase(tempUrl) Like "ws://*" Or LCase(tempUrl) Like "https://*" Or LCase(tempUrl) Like "http://*") Then
            tempUrl = "http://" & tempUrl
        End If
        
        Set RegExp = CreateObject("vbscript.regexp")
        RegExp.Global = True
        
        
        RegExp.Pattern = "(https?|http|wss|ws)://[-A-Za-z0-9+&@#/%?=~_|!:,.;]+[-A-Za-z0-9+&@#/%=~_|]"
        
        If (RegExp.Test(tempUrl)) = True Then
            
            RegExp.Pattern = "(?:([^:/?#]+):)?(?://([^/:?#]*))?(?:\:(\d*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?"
            
            'RegExp.Pattern = "(\w+)://([^/:]+):(\d*)?([^# ]*)"
            Dim S As String
            jiexiUrl.Proc = RegExp.Replace(tempUrl, "$1")
            S = jiexiUrl.Proc & "://"
            
            
            jiexiUrl.Host = RegExp.Replace(tempUrl, "$2")
            S = S & jiexiUrl.Host
            
            jiexiUrl.Port = RegExp.Replace(tempUrl, "$3")
            If Len(jiexiUrl.Port) > 0 Then
                S = S & ":" & jiexiUrl.Port
            Else
                
                jiexiUrl.Port = "-1"
                
            End If
            
            If CLng(jiexiUrl.Port) < 0 Or CLng(jiexiUrl.Port) > 65535 Then
                If LCase(jiexiUrl.Proc) = "https" Or LCase(jiexiUrl.Proc) = "wss" Then
                    jiexiUrl.Port = "443"
                Else
                    jiexiUrl.Port = "80"
                End If
                
            End If
            
            
            S = Replace(tempUrl, S, "")
            
            
            jiexiUrl.Path = S
            If Len(jiexiUrl.Path) = 0 Then jiexiUrl.Path = "/"
            
            jiexiUrl.url = tempUrl
            
            
        Else
            
            RaiseEvent OnError(3007, "描述:Url地址格式错误")
            
            '1009 表示端点因接收到的消息对它的处理来说太大而终止连接。
            
            Call OnClose
            
        End If
        
        Set RegExp = Nothing
        
        
    End Function
    
    
    
    
    
    Private Sub GetHeaders()
        
        Dim Str As String
        
        Str = "GET " & SendUrl.Path & " HTTP/1.1" & vbCrLf
        
        Str = Str & "Upgrade: WebSocket" & vbCrLf
        
        Str = Str & "Connection: Upgrade" & vbCrLf
        
        Str = Str & "Host: " & SendUrl.Host & vbCrLf
        
        Str = Str & "Origin: " & Winsock1.LocalIP & vbCrLf
        
        Str = Str & "Pragma: no -cache" & vbCrLf
        
        Str = Str & "cache -Control: no -cache" & vbCrLf
        
        Str = Str & "Sec-WebSocket-Key: " & SendUrl.wsKey & vbCrLf
        
        Str = Str & "Sec-WebSocket-Version: 13" & vbCrLf
        
        Str = Str & "Sec -WebSocket - Extensions: x -webkit - deflate - Frame;permessage-deflate; client_max_window_bits" & vbCrLf
        
        Str = Str & "User-Agent: Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/69.0.2171.99 Safari/537.36" & vbCrLf & vbCrLf
        
        SendUrl.Header = Str
        
    End Sub

    第二步新建一个窗体,添加WebSock控件,命名WebSocket1。添加三个按钮,分别命名cmdConn,cmdSend,Command1

    Private Sub Showlog(Str As String)
        If Len(txtLog.Text) > 15000 Then txtLog.Text = ""
        txtLog.Text = txtLog.Text & Time & " " & Str & vbCrLf
        txtLog.SelStart = Len(txtLog.Text)
    End Sub
    
    
    Private Sub cmdConn_Click()
        WebSocket1.Connect txtUrl.Text
        
        
    End Sub
    
    
    Private Sub cmdSend_Click()
        
        WebSocket1.SendData txtSend.Text, 1, True
    End Sub
    
    Private Sub Command1_Click()
        WebSocket1.OnClose
    End Sub
    
     
    
    Private Sub Form_Load()
        
    End Sub
    
    Private Sub WebSocket1_OnClose()
        
        Showlog "已经关闭"
    End Sub
    
    Private Sub WebSocket1_OnError(Number As Long, Str As String)
        
        Showlog Number & Str
    End Sub
    
    
    
    
    
    Private Sub WebSocket1_OnMessage(ByVal RecvData As Variant, ByVal GetMsg As Long, sFIN As Boolean)
        If GetMsg = 1 Then
            Showlog CStr(RecvData)
        Else
            
            Showlog StrConv(RecvData, vbFromUnicode)
        End If
    End Sub
    
    Private Sub WebSocket1_OnOpen()
        
        Showlog Timer & "已经连接"
    End Sub

     

     

     

     

     

    展开全文
  • 这是个完整的VS2017 VB.net工程,是OPC UA客户端的,内有OPC UA Helper,可以浏览OPC服务器的变量数据,通过施耐德M241 PLC通讯验证,能单个或者多个数据的读写,例子是按钮操作单次度写,您可以自行添加定时器...
  • VB6.0 TCP通信示例 服务端+客户端 网口助手源码 SocketTool
  • 服务器端代码: #!/usr/bin/python3 # -*- coding: UTF-8 -*- # 文件名:server.py # 导入 socket、sys 模块 import socket import sys # 创建 socket 对象 serversocket = socket.socket( socket.AF_INET, ...

    服务器端代码:

    #!/usr/bin/python3
    # -*- coding: UTF-8 -*-
    # 文件名:server.py
    
    # 导入 socket、sys 模块
    import socket
    import sys
    
    # 创建 socket 对象
    serversocket = socket.socket(
                socket.AF_INET, socket.SOCK_STREAM) 
    
    # 获取本地主机名
    host = socket.gethostname()
    port = 9999
    
    # 绑定端口号
    serversocket.bind((host, port))
    
    # 设置最大连接数,超过后排队
    serversocket.listen(5)
    
    while True:
        # 建立客户端连接
        clientsocket,addr = serversocket.accept()      
    
        print("连接地址: %s" % str(addr))
    
        msg='欢迎访问菜鸟教程!'+ "\r\n"
        # 中文问题
        reload(sys)
        sys.setdefaultencoding('utf-8')
    
        clientsocket.send(msg.encode('utf-8'))
        clientsocket.close()
    

    客户端代码:

    #!/usr/bin/python3
    # -*- coding: UTF-8 -*-
    # 文件名:client.py
    
    # 导入 socket、sys 模块
    import socket
    import sys
    
    # 创建 socket 对象
    s = socket.socket(socket.AF_INET, socket.SOCK_STREAM) 
    
    # 获取本地主机名
    host = socket.gethostname() 
    
    # 设置端口号
    port = 9999
    
    # 连接服务,指定主机和端口
    s.connect((host, port))
    
    # 接收小于 1024 字节的数据
    msg = s.recv(1024)
    
    s.close()
    
    print (msg.decode('utf-8'))
    展开全文
  • VB winsock服务端连接多个客户端示例

    热门讨论 2010-11-10 13:43:43
    VB用winsock控件实现C/S网络结构,一个服务端连接多个客户端代码示例。动态加载winsock数组实现该功能。代码来自网络,经过本人修改测试,编译测试成功通过。
  • socket通讯是最常用的通讯协议,以服务器和客户端的形式体现,在VB.net中,也可以实现。 在visual studio2019中新建两个窗体项目,分别命名为serverclient

    socket通讯是最常用的通讯协议,以服务器和客户端的形式体现,在VB.net中,也可以实现。
    废话不多说,请看实例:
    在visual studio2019中新建两个窗体项目,分别命名为server和client。
    在这里插入图片描述
    server窗体代码:
    在这里插入图片描述

    Imports System.Net
    Imports System.Net.Sockets
    Imports System.Text
    Imports System.Threading
    
    
    
    
    
    Public Class Form1
    
        Dim ip As IPAddress
        Dim port As Integer
        Dim ipe As IPEndPoint
        Dim s As Socket
        Dim svr As Socket
    
        Delegate Sub sockivo(dt As String)
    
        Dim data1 As String
    
        Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
            ip = IPAddress.Parse("127.0.0.1")
            port = 2000
            ipe = New IPEndPoint(ip, port)
            s = New Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp)
            s.Bind(ipe)
            s.Listen(10)
            svr = s.Accept()
    
            Console.WriteLine("client:" & svr.RemoteEndPoint.ToString())
    
            Dim th1 As New Thread(AddressOf sockrec)
            th1.Start()
    
    
    
        End Sub
    
        Private Sub sockrec()
    
    
            While True
    
                Dim recbyte(1024) As Byte
    
                svr.Receive(recbyte)
    
    
                data1 = Encoding.GetEncoding("gb2312").GetString(recbyte)
    
                Dim sockivo1 As New sockivo(AddressOf sockrecdata)
    
                Me.Invoke(sockivo1, data1)
    
            End While
    
    
    
    
    
    
        End Sub
    
        Private Sub sockrecdata(dt As String)
    
            ListView1.Items.Add("clientA:" + dt + vbCrLf, 1)
    
    
        End Sub
    
        Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
    
    
            Dim sendbyt(1024) As Byte
    
            sendbyt = Encoding.GetEncoding("gb2312").GetBytes(TextBox1.Text)
    
    
    
            svr.Send(sendbyt)
    
            ListView1.Items.Add("me:" + TextBox1.Text + vbCrLf, 0)
    
            TextBox1.Clear()
    
    
    
        End Sub
    End Class
    
    

    client窗体代码:

    Imports System.Net
    Imports System.Net.Sockets
    Imports System.Text
    Imports System.Threading
    
    
    
    
    
    Public Class Form1
    
        Dim ip As IPAddress
        Dim port As Integer
        Dim ipe As IPEndPoint
        Dim s As Socket
    
        Delegate Sub sockivo(dt As String)
    
        Dim data1 As String
    
    
    
    
    
        Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
    
            ip = IPAddress.Parse("127.0.0.1")
            port = 2000
            ipe = New IPEndPoint(ip, port)
            s = New Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp)
    
            s.Connect(ipe)
    
            Dim th1 As New Thread(AddressOf sockrec)
            th1.Start()
    
        End Sub
    
    
        Private Sub sockrec()
    
    
            While True
    
    
                Dim recbyt(1024) As Byte
                s.Receive(recbyt)
                data1 = Encoding.GetEncoding("gb2312").GetString(recbyt)
                Dim sockivo1 As New sockivo(AddressOf sockrecdata)
    
                Me.Invoke(sockivo1, data1)
    
    
            End While
    
    
    
    
    
        End Sub
        Private Sub sockrecdata(dt As String)
    
    
    
            ListView1.Items.Add("server:" + dt + vbCrLf, 0)
    
    
    
    
        End Sub
    
        Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
    
            Dim sendbyt(1024) As Byte
    
            sendbyt = Encoding.GetEncoding("gb2312").GetBytes(TextBox1.Text)
    
            s.Send(sendbyt)
    
            ListView1.Items.Add("me:" + TextBox1.Text + vbCrLf, 1)
    
            TextBox1.Clear()
    
    
        End Sub
    End Class
    
    

    测试效果图:
    在这里插入图片描述
    源程序超链接:
    https://download.csdn.net/download/normer123456/21733993

    展开全文
  • VB写一个VB简单收发邮件客户端程序源码,只是一个邮件客户端,并没有邮件发送功能,这个管理程序还可以下载查看附件,不过程序需要依赖OutLook进行邮件服务器设置,实际上是比较简单的程序。
  • VB连接FTP客户端

    热门讨论 2011-12-10 15:09:47
    VB连接FTP的客户端。实现了文件的上传与下载,具体情况视服务器权限而定
  • VB 网络聊天服务器客户端源程序!!!!!!!!

空空如也

空空如也

1 2 3 4 5 ... 20
收藏数 28,573
精华内容 11,429
关键字:

vb服务器和客户端