www.pudn.com > TCPServer.rar > frmTcpServer.frm

VERSION 5.00 
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX" 
Begin VB.Form frmTcpServer  
   Caption         =   "TCP Server" 
   ClientHeight    =   3810 
   ClientLeft      =   60 
   ClientTop       =   450 
   ClientWidth     =   5565 
   LinkTopic       =   "Form1" 
   ScaleHeight     =   3810 
   ScaleWidth      =   5565 
   StartUpPosition =   3  'Windows Default 
   Begin VB.ListBox lisRcv  
      Height          =   1425 
      Left            =   960 
      TabIndex        =   6 
      Top             =   2040 
      Width           =   1935 
   End 
   Begin VB.TextBox txtRcv  
      Height          =   375 
      Index           =   0 
      Left            =   1080 
      TabIndex        =   3 
      Top             =   1440 
      Width           =   3015 
   End 
   Begin VB.CommandButton btnStop  
      Caption         =   "&Stop" 
      Height          =   375 
      Left            =   4320 
      TabIndex        =   2 
      Top             =   3000 
      Width           =   975 
   End 
   Begin VB.CommandButton btnStart  
      Caption         =   "&Start" 
      Height          =   375 
      Left            =   3120 
      TabIndex        =   1 
      Top             =   3000 
      Width           =   975 
   End 
   Begin VB.TextBox TextSend  
      Height          =   375 
      Index           =   0 
      Left            =   1080 
      TabIndex        =   0 
      Top             =   840 
      Width           =   3015 
   End 
   Begin MSWinsockLib.Winsock TcpServer  
      Index           =   0 
      Left            =   240 
      Top             =   3120 
      _ExtentX        =   741 
      _ExtentY        =   741 
      _Version        =   393216 
   End 
   Begin VB.Label lblRcv  
      Caption         =   "Receive" 
      Height          =   375 
      Left            =   240 
      TabIndex        =   5 
      Top             =   1440 
      Width           =   735 
   End 
   Begin VB.Label lblSend  
      Caption         =   "Send" 
      Height          =   375 
      Left            =   360 
      TabIndex        =   4 
      Top             =   840 
      Width           =   615 
   End 
End 
Attribute VB_Name = "frmTcpServer" 
Attribute VB_GlobalNameSpace = False 
Attribute VB_Creatable = False 
Attribute VB_PredeclaredId = True 
Attribute VB_Exposed = False 
Option Explicit 
Private WSockIndex As Integer, iTimes As Integer 
 
Private Sub btnStart_Click() 
  Dim bytemsg() As Byte 
   
  On Error GoTo ErrSnd 
  bytemsg = StrConv(TextSend(WSockIndex).Text, vbFromUnicode) 
   
  TcpServer(WSockIndex).SendData bytemsg 
  Exit Sub 
ErrSnd: 
  MsgBox "Send message error!", vbOKCancel + vbCritical, Me.Caption 
End Sub 
 
Private Sub Form_Load() 
    'TcpSever为服务器的“监听”WinSock控件 
    btnStart.Enabled = False 
    btnStop.Enabled = False 
     
    WSockIndex = 0 
 
    TcpServer(0).LocalPort = 1001 
 
    TcpServer(0).Listen 
 
End Sub 
 
Private Sub TcpServer_ConnectionRequest(Index As Integer, ByVal requestID As Long) 
     If Index = 0 Then 
 
     '生成新的WinSock控件响应客户端的请求 
 
     WSockIndex = WSockIndex + 1 
 
     Load TcpServer(WSockIndex) 
 
     TcpServer(WSockIndex).LocalPort = 0 
 
     '检查控件的 State 属性是否为关闭的。如果不是，在接受新的连接之前先关闭此连接 
 
     If TcpServer(WSockIndex).State <> sckClosed Then 
 
     TcpServer(WSockIndex).Close 
 
     End If 
 
     '接受具有requestID参数的连接 
 
     TcpServer(WSockIndex).Accept requestID 
 
     '为新的连接设立双向数据传输的TextBox 
 
     If WSockIndex > 1 Then 
 
     Load TextSend(WSockIndex - 1) 
 
     TextSend(WSockIndex - 1).Left = TextSend(WSockIndex - 2).Left + (20 + TextSend(WSockIndex - 2).Width) '(WSockIndex－1) 
 
     Load txtRcv(WSockIndex - 1) 
 
     txtRcv(WSockIndex - 1).Left = txtRcv(WSockIndex - 2).Left + (20 + txtRcv(WSockIndex - 2).Width) '(WSockIndex－1) 
 
     TextSend(WSockIndex - 1).Visible = True 
 
     txtRcv(WSockIndex - 1).Visible = True 
 
     End If 
 
    End If 
 
End Sub 
 
Private Sub TcpServer_DataArrival(Index As Integer, ByVal bytesTotal As Long) 
On Error GoTo WinsockLogInerr 
 
    Dim byteData()  As Byte 
    Dim sSTX        As String 
    Dim sETX        As String 
    Dim bETX        As Boolean 
     
    Dim sRcvData As String 
    ' Message 备炼 ============================================ 
    ' [stx + msgid(6) + msglen(5) (ex>00053) + 皋矫瘤悸 + etx] 
    ' ========================================================= 
 
    'Byte硅凯 函荐 犁急攫 
    ReDim byteData(bytesTotal - 1) 
 
    ' 单捞鸥甫 佬澜 
    TcpServer(Index).GetData byteData, vbArray + vbByte 
 
    '盖第狼 茄官捞飘啊 ETX牢瘤... 
    sETX = RightB(byteData, 1) 
    sETX = StrConv(sETX, vbUnicode) 
    If sETX = Chr(3) Then 
        'ETX甫 肋扼辰促... 
        byteData = MidB(byteData, 1, bytesTotal - 1) 
        bETX = True 
    Else 
        bETX = False 
    End If 
 
    '盖菊狼 茄官捞飘啊 STX牢瘤... 
    sSTX = LeftB(byteData, 1) 
    sSTX = StrConv(sSTX, vbUnicode) 
    If sSTX = Chr(2) Then 
        'STX老 版快 盖菊狼 STX甫 猾蔼阑 Global 函荐肺 历厘... 
        byteData = MidB(byteData, 2) 
        sRcvData = StrConv(byteData, vbUnicode) 
    Else 
        'STX,ETX啊 葛滴 绝阑 版快: Global 函荐肺 穿利 历厘... 
        sRcvData = sRcvData & StrConv(byteData, vbUnicode) 
    End If 
     
    iTimes = iTimes + 1 
     
    txtRcv(0).Text = sRcvData 
    lisRcv.AddItem sRcvData & iTimes 
    Exit Sub 
 
WinsockLogInerr: 
 
End Sub