frmserver.frm

电子书“Visual Basic 6 网络编程实例教程.rar”

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form FrmServer 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "基于WINSOCK的聊天程序—服务器端"
   ClientHeight    =   4290
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5865
   Icon            =   "FrmServer.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4290
   ScaleWidth      =   5865
   StartUpPosition =   3  '窗口缺省
   Begin MSWinsockLib.Winsock TcpServer 
      Left            =   4200
      Top             =   1680
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.CommandButton cmdSend 
      Caption         =   "发送"
      Height          =   495
      Left            =   4200
      TabIndex        =   5
      Top             =   3600
      Width           =   1455
   End
   Begin VB.CommandButton cmdDisConnect 
      Caption         =   "断开连接"
      Height          =   495
      Left            =   4200
      TabIndex        =   4
      Top             =   2160
      Width           =   1455
   End
   Begin VB.CommandButton cmdConnect 
      Caption         =   "监听"
      Height          =   495
      Left            =   4200
      TabIndex        =   3
      Top             =   720
      Width           =   1455
   End
   Begin VB.TextBox TxtSend 
      Height          =   975
      Left            =   120
      MultiLine       =   -1  'True
      TabIndex        =   2
      Text            =   "FrmServer.frx":030A
      Top             =   3120
      Width           =   3735
   End
   Begin VB.TextBox TxtReceive 
      Height          =   1935
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Text            =   "FrmServer.frx":0314
      Top             =   720
      Width           =   3735
   End
   Begin VB.TextBox TxtErr 
      Height          =   375
      Left            =   120
      TabIndex        =   0
      Text            =   "TxtErr"
      Top             =   240
      Width           =   5655
   End
   Begin VB.Label Label2 
      BackStyle       =   0  'Transparent
      Caption         =   "Label2"
      ForeColor       =   &H00FF0000&
      Height          =   255
      Left            =   4680
      TabIndex        =   7
      Top             =   1800
      Width           =   975
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "名称："
      Height          =   180
      Left            =   4560
      TabIndex        =   6
      Top             =   1440
      Width           =   540
   End
   Begin VB.Line Line2 
      BorderColor     =   &H80000011&
      X1              =   120
      X2              =   5760
      Y1              =   2910
      Y2              =   2910
   End
   Begin VB.Line Line1 
      BorderColor     =   &H00FFFFFF&
      X1              =   120
      X2              =   5760
      Y1              =   2880
      Y2              =   2880
   End
End
Attribute VB_Name = "FrmServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim myname As String
Private isConnectedFlag As Boolean
Private sClientChatName As String  '保存连接用户的名称
Const msgTitle As String = "Winsock聊天服务器端示例"

Private Sub cmdConnect_Click()
    '本方首先假设服务器端的Winsock控件已被关闭，
    '然后给控件LocalPort分配一个端口。
    '注意的是，不能分配系统服务文件中的友元名称。
    '一旦分配了端口号，将唤醒WinsockDEListen方法。
    TcpServer.Close
    TcpServer.LocalPort = 1544
    TcpServer.Listen
    '如果连接成功，控件状态是'sckListening'
    If TcpServer.State = sckListening Then
        Me.Caption = "TCP服务器: 正监听..."
        cmdDisConnect.Caption = "停止监听"
        cmdDisConnect.Enabled = TcpServer.State = sckListening
        cmdConnect.Enabled = TcpServer.State = sckClosed
    End If
    '如果连接过程中发生了错误，将在txtErr文本框中显示错误信息
    TxtErr.Text = Err.Description
End Sub

Private Sub cmdDisconnect_Click()
    If TcpServer.State = sckListening Or _
        TcpServer.State = sckConnected Then
        TcpServer.Close
        isConnectedFlag = TcpServer.State = sckConnected
        Me.Caption = "TCP服务器已关闭了"
        cmdDisConnect.Enabled = isConnectedFlag = True
        cmdConnect.Enabled = isConnectedFlag = False
    End If
End Sub

Private Sub cmdSend_Click()
    Call TransmitMessage
End Sub

Private Sub Form_Load()
    TxtErr.Text = ""
    TxtSend.Text = ""
    TxtReceive.Text = ""
    myname = "server"
    Label2.Caption = myname
    Load FrmClient
    FrmClient.Show '显示客户端窗体
End Sub

Private Sub Form_Unload(Cancel As Integer)
    TcpServer.Close
    Unload FrmClient
    Set FrmClient = Nothing
    Set FrmServer = Nothing
End Sub

Private Sub tcpServer_Close()
    If isConnectedFlag = True Then
        If TcpServer.State = sckClosing Then
             '确保避免循环
            isConnectedFlag = False
            '更新窗体标题
            Me.Caption = "TCP服务器正关闭..."
            '通知用户
            MsgBox "到' " & sClientChatName & _
            " '的连接意外终止。", _
            vbExclamation Or vbOKOnly, msgTitle
            '关闭连接
            TcpServer.Close
            cmdDisConnect.Enabled = isConnectedFlag
            cmdConnect.Enabled = Not isConnectedFlag
        End If
    End If
    Me.Caption = "TCP服务器已关闭了"
End Sub

Private Sub tcpServer_ConnectionRequest(ByVal requestID As Long)
    '检查控件是否处于已被关闭了状态，如果不是 ，则在接受新的连接
    '前先关闭连接
    If TcpServer.State <> sckClosed Then
        TcpServer.Close
    End If
    TcpServer.Accept requestID
End Sub

Private Sub tcpServer_DataArrival(ByVal bytesTotal As Long)
    Dim strData As String
     '保存输入数据
     Dim buff As String

     If isConnectedFlag = True Then
        '建立了连接，设置isConnectedFlag表示。
        '程序会认为以后的输入数据为聊天内容
        TcpServer.GetData strData
        '如果文本框txtReceive中有数据（不是第一行），
        '此时，需要在各行之间插入VBcrlf换行符。
        If Len(TxtReceive.Text) Then
            buff = buff & vbCrLf & sClientChatName & " :" & vbTab & strData
        Else
            buff = buff & sClientChatName & " :" & vbTab & strData
        End If
        '假如新的字符串到达了文本框txtReceive的最后，则进行滚动
        With TxtReceive
            .SelStart = Len(TxtReceive.Text)
            .SelText = buff
            .SelStart = Len(TxtReceive.Text)
        End With
    Else
        '设置isConnectedFlat标志，以避免下次再次进入本部分
        isConnectedFlag = True
        
        TcpServer.GetData strData
        sClientChatName = strData
        Me.Caption = "TCP服务器:正与" & sClientChatName & "聊天"

        TcpServer.SendData myname
  
        cmdDisConnect.Caption = "断开连接"
        TxtSend.SetFocus
    End If
End Sub

Private Sub tcpServer_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)
    MsgBox "tcpServer Error: " & Number & vbCrLf & Description, _
            vbExclamation Or vbOKOnly, msgTitle
    CancelDisplay = True
    TcpServer.Close
End Sub

Private Sub txtSend_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        Call TransmitMessage
    End If
End Sub

Private Sub TransmitMessage()
    Dim buff As String

    On Local Error GoTo TransmitMessage_error
    TcpServer.SendData TxtSend.Text
    
    If Len(TxtReceive.Text) Then
        buff = buff & vbCrLf & myname & " :" & vbTab & TxtSend.Text
    Else
        buff = buff & myname & " :" & vbTab & TxtSend.Text
    End If

    With TxtReceive
        .SelStart = Len(TxtReceive.Text)
        .SelText = buff
        .SelStart = Len(TxtReceive.Text)
    End With

    TxtSend.Text = ""
TransmitMessage_exit:
    Exit Sub
TransmitMessage_error:
    Select Case Err
    Case sckBadState:         MsgBox Err.Description & "." & vbCrLf & _
                        "服务器未连接到客户端", _
                        vbExclamation Or vbOKOnly, msgTitle
    Case Else:               MsgBox Err.Description & ".", _
                        vbExclamation Or vbOKOnly, msgTitle
    End Select
    Resume TransmitMessage_exit
End Sub