ftcpserver.frm

在Windows下用WinSock API开发的示例

VERSION 5.00
Begin VB.Form fTcpServer 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Winsock API Demo (TCP Server)"
   ClientHeight    =   5025
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5655
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5025
   ScaleWidth      =   5655
   StartUpPosition =   3  'Windows Default
   Begin VB.TextBox txtDisplay 
      Height          =   4215
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Top             =   120
      Width           =   5415
   End
   Begin VB.CommandButton cmdClose 
      Caption         =   "&Close"
      Height          =   375
      Left            =   4440
      TabIndex        =   0
      Top             =   4560
      Width           =   1095
   End
End
Attribute VB_Name = "fTcpServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'
' ---------------------------------------------------------------------------------
' File...........: fTcpServer.frm
' Author.........: Will Barden
' Created........: 04/06/03
' Modified.......: 04/06/03
' Version........: 1.0
' Website........: http://www.WinsockVB.com
' Contact........: [e-mail]
'
' A simple form to demonstrate the techniques involved in setting up a TCP
' connection and transmitting data both ways. Start this first, then start
' the client. It runs quickly, but you can step through both apps with F8.
' ---------------------------------------------------------------------------------
'
' ---------------------------------------------------------------------------------
' Private variables.
' ---------------------------------------------------------------------------------
'
Private m_hServerSocket    As Long
'
' ---------------------------------------------------------------------------------
' Form events.
' ---------------------------------------------------------------------------------
'
Private Sub Form_Load()
   '
Dim udtData As WSADATA
Dim lngRet  As Long
   '
   Me.Show
   '
   ' Start Winsock up, and call the main sub.
   Call LogText("Starting Winsock 2")
   lngRet = WSAStartup(WINSOCK_V2_2, udtData)
   If (lngRet = ERROR_SUCCESS) Then
      '
      Call DoWinsockStuff
      '
      Call WSACleanup
      '
   Else
      Call LogText("WSAStartup() failed: " & vbGetLastError(lngRet))
   End If
   '
End Sub
'
' ---------------------------------------------------------------------------------
' Control events.
' ---------------------------------------------------------------------------------
'
Private Sub cmdClose_Click()
   '
   Call Unload(Me)
   '
End Sub
'
' ---------------------------------------------------------------------------------
' Private helpers
' ---------------------------------------------------------------------------------
'
Private Sub DoWinsockStuff()
   '
Dim udtAddr       As sockaddr_in
Dim udtRemote     As sockaddr_in
Dim lngRet        As Long
Dim hAccepted     As Long
Dim strData       As String
   '
   ' Create a server socket. This will be used to listen for connection requests.
   Call LogText("Creating a server socket")
   m_hServerSocket = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
   If (m_hServerSocket <> INVALID_SOCKET) Then
      '
      ' Bind the server socket to all local addresses.
      Call LogText("Binding server socket to the local addresses")
      With udtAddr
         .sin_family = AF_INET
         .sin_addr.s_addr = vbInetAddr(INADDR_ANY)
         .sin_port = htons(10101)
      End With
      If (bind(m_hServerSocket, udtAddr, LenB(udtAddr)) = SOCKET_ERROR) Then
         Call LogText("bind() failed: " & vbGetLastError())
      Else
         '
         ' Put the socket in a listening state, and accept the next request.
         Call LogText("Listening for connection requests")
         Call listen(m_hServerSocket, SOMAXCONN)
         hAccepted = accept(m_hServerSocket, udtRemote, LenB(udtRemote))
         '
         ' Make sure we've got a valid socket handle here.
         If (hAccepted = INVALID_SOCKET) Then
            Call LogText("accept() failed: " & vbGetLastError())
         Else
            '
            ' Receive the data the client is sending us. Once it's all been
            ' received, reverse it and send it back again!
            strData = RecvData(hAccepted)
            Call LogText("Received: " & strData)
            '
            Call SendData(hAccepted, StrReverse(strData))
            Call LogText("Sent: " & StrReverse(strData))
            '
         End If
         '
      End If
      '
      ' Since we're done, close the connection.
      Call closesocket(hAccepted)
      Call LogText("Connection closed")
      '
   Else
      ' We somehow failed to create a socket.. odd..
      Call LogText("Socket creation failed: " & vbGetLastError())
   End If
   '
End Sub
'
Private Sub SendData(ByVal hSocket As Long, _
                     ByVal strData As String)
   '
Dim bytData()     As Byte
Dim lngCount      As Long
Dim lngBytesSent  As Long
   '
   ' Convert the string data to a byte array, and count how many bytes there are.
   bytData = StrConv(strData, vbFromUnicode)
   lngCount = UBound(bytData) - LBound(bytData) + 1
   '
   ' Send the byte array, and check the return value for errors, just in case.
   lngBytesSent = send(hSocket, bytData(0), lngCount, 0&)
   If (lngBytesSent = SOCKET_ERROR) Then
      Call LogText("send() failed: " & vbGetLastError())
   End If
   '
End Sub
'
Private Function RecvData(ByVal hSocket As Long) As String
   '
Dim bytData()        As Byte
Dim lngCount         As Long
Dim lngBytesReceived As Long
Dim strData          As String
   '
   ' Prepare our receive buffer to 1KB (should be plenty of space).
   ReDim bytData(0 To 1023) As Byte
   lngCount = UBound(bytData) - LBound(bytData) + 1
   '
   ' Call receive, and check for errors.
   lngBytesReceived = recv(hSocket, bytData(0), lngCount, 0&)
   If (lngBytesReceived = SOCKET_ERROR) Then
      Call LogText("recv() failed: " & vbGetLastError())
   Else
      ' Convert the received data back into a string and return.
      strData = StrConv(bytData, vbUnicode)
      RecvData = Mid$(strData, 1, lngBytesReceived)
   End If
   '
End Function
'
Private Sub LogText(ByVal strText As String)
   '
   ' Add the text onto the end of the textbox.
   With txtDisplay
      .SelStart = Len(.Text)
      .SelText = strText & vbCrLf
      .SelStart = Len(.Text)
   End With
   '
End Sub
'
' ---------------------------------------------------------------------------------
' EOF.
' ---------------------------------------------------------------------------------
'