myserver.frm

来自「本书源码主要针对目前流行的FTP、HTTP、E-mail、Telnet、ICMP」· FRM 代码 · 共 166 行

VERSION 5.00
Begin VB.Form myserver 
   Caption         =   "TCP连接服务器程序"
   ClientHeight    =   2280
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4110
   LinkTopic       =   "Form1"
   ScaleHeight     =   2280
   ScaleWidth      =   4110
   StartUpPosition =   3  'Windows Default
   Begin VB.TextBox txtPort 
      Height          =   375
      Left            =   1560
      TabIndex        =   2
      Text            =   "5000"
      Top             =   840
      Width           =   1215
   End
   Begin VB.CommandButton cmdStart 
      Caption         =   "开始侦听"
      Height          =   735
      Left            =   1320
      TabIndex        =   0
      Top             =   1440
      Width           =   1695
   End
   Begin VB.Label Label1 
      Caption         =   "请输入侦听端口，注意客户端和服务器端在连接时端口要保持一致"
      Height          =   615
      Left            =   840
      TabIndex        =   1
      Top             =   240
      Width           =   2775
   End
End
Attribute VB_Name = "myserver"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'
' Project: vbtcp
'
' 程序说明：
'    该程序包含了一个TCP服务器程序和客户端程序。服务器端创建了一个TCP侦听socket并等待客户
'    端连接。一旦连接建立成功，服务器端接受客户端的程序，并把接受到的数据返回到客户端。
'    服务器端使用了阻塞式sockets来接受和发送数据。这意味着服务器端程序一旦建立，用户界面不能
'    被刷新。
'    客户端程序非常简单，用户确定服务器名字和端口号，然后就可以连接服务器了。用户只要在发送
'    数据文本框中输入文字，并单击发送按钮，就可以在显示文本框中读取回显数据。

Option Explicit

'
' 窗体载入事件
'
'    该事件中，要确定Winsock DLL已经被正确
'    的载入
'
Sub Form_Load()
    If TCPIPStartup Then
        cmdStart.Enabled = True
    Else
        MsgBox "Windows Socketsb不能被初始化：" & Err.LastDllError
    End If
End Sub

'
' Subroutine: Form_Unload窗体卸载事件
'    卸载掉Winsock DLL
'
Private Sub Form_Unload(Cancel As Integer)
    TCPIPShutDown
End Sub

'
' CmdStart_Click事件
'
' Description:
'
'    该事件中启动服务器程序，程序首先创建了一个socket，该socket被绑定到
'    一个指定的端口，然后等待客户端的连接。连接建立完毕，便等待
'    客户端的数据发送，然后把接受到的数据回显给客户端。
'    注意采用的式阻塞式socket。
'
Private Sub CmdStart_Click()
   Dim addr As sockaddr, client_addr As sockaddr, addrlen As Long, client_addrlen As Long, pSockAddr As Long
   Dim msg_sock As Long, accept_sock As Long, msgstr As String
   Dim i As Long
   
   cmdStart.Enabled = False
   
   '获取socket句柄
   accept_sock = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
   
   If accept_sock = INVALID_SOCKET Then
       MsgBox "Couldn't create socket(). Error:" & Err.LastDllError, "Accept"
       Exit Sub
   End If
   '
   ' 设定socket端口
   '
   addr.sin_family = AF_INET
   addr.sin_port = 5000 'htons(CLng(txtPort.Text))
   addr.sin_addr = INADDR_ANY
      
   '绑定到socket上
   If bind(accept_sock, addr, Len(addr)) = SOCKET_ERROR Then
       MsgBox "Couldn't bind() to socket. Error: " & Err.LastDllError
       closesocket (accept_sock)
       Exit Sub
   End If

   '开始侦听
   If listen(accept_sock, 1) = SOCKET_ERROR Then
       MsgBox "Couldn't listen() to socket. Error: " & Err.LastDllError
       closesocket (accept_sock)
       Exit Sub
   End If
   
   client_addrlen = Len(client_addr)
   '
   ' 等待客户端连接
   '
   msg_sock = accept(accept_sock, client_addr, client_addrlen)
   If msg_sock = INVALID_SOCKET Then
       MsgBox "Couldn't accept an socket connection. Error: " & Err.LastDllError
       closesocket (accept_sock)
       Exit Sub
   End If
  
   Dim RetMsg As String '循环接收和发送知道其他程序关闭socket
   Dim dwRc As Long
   'DoEvents

   Do
    RetMsg = String(7000, 0)
    dwRc = recv(msg_sock, ByVal RetMsg, 7000, 0)
    If dwRc = SOCKET_ERROR Then
         MsgBox "Couldn't recieve data from remote Socket. Error: " & Err.LastDllError
         closesocket (accept_sock)
         closesocket (msg_sock)
         cmdStart.Enabled = True
         Exit Sub
     End If
     '
     ' 读取数据，并返回数据到客户端
     '
     dwRc = send(msg_sock, ByVal RetMsg, Len(RetMsg), 0)
     If dwRc = SOCKET_ERROR Then
         MsgBox "Couldn't send data to remote Socket. Error: " & Err.LastDllError
         closesocket (accept_sock)
         closesocket (msg_sock)
         cmdStart.Enabled = True
         Exit Sub
     End If
    Loop
    closesocket (msg_sock)
    closesocket (accept_sock)
   
    cmdStart.Enabled = True
                 
End Sub