聊天程序.txt

用“WinSock”控件建立了一个“聊天”程序。该程序可以同在同一台计算机上运行

客户端程序：
 Dim s As String
Dim NewClient As Boolean
设置服务器IP和端口号，单击“连接”按钮将开始连接服务器，代码如下：
Private Sub cmdConnect_Click()
＇发生错误时跳转
On Error GoTo errhandle:
＇设置服务器IP和端口
tcpClient.RemoteHost = txtHost.Text
tcpClient.RemotePort = txtPort.Text
＇开始连接
tcpClient.Connect
＇设置标志变量
NewClient = True
Exit Sub
＇错误处理
errhandle:
    MsgBox Err.Description
End Sub

Private Sub Command1_Click()
End Sub

Private Sub Command2_Click()
End Sub

Private Sub Command3_Click()
End Sub

Private Sub cmdExit_Click()
Unload frmClient
End Sub

Private Sub cmdsave_Click()
'Dim s As String
'CommonDialog1.Filter = "文本文件|*.txt"
'CommonDialog1.ShowSave
Open "d:\1.txt" For Output As #1
s = rtbIn.Text
'Do While Not EOF(1)
Print #1, s
'Loop
Close #1
'frmClientLogIn.Show
End Sub

Private Sub cmdLogin_Click()
Load frmClientLogIn
frmClientLogIn.Show
End Sub

单击“断开”按钮将向服务器发送中断连接的请求，代码如下：
＇中断连接
Private Sub cmdQuit_Click()
＇发生错误时跳转
On Error GoTo errhandle:
＇发送中断连接的请求
tcpClient.SendData "^q" & lblName.Caption & CStr(Now())
Exit Sub
errhandle:
MsgBox Err.Description
End Sub

Private Sub Form_Load()
'txtHost.Text = "166.111.162.179"
'txtPort.Text = "5000"
Me.cmdConnect.Enabled = False
Me.cmdQuit.Enabled = False
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'FrmWebBroswer.Show
End Sub

Private Sub tcpClient_Connect()
txtOut.Locked = False

tcpClient.SendData "/" + lblName.Caption
End Sub

利用DataArrival时间获得服务器发送的信息,代码如下：
Private Sub tcpClient_DataArrival(ByVal bytesTotal As Long)
Dim sData As String 
＇判断是否为连接成功信息
If NewClient Then
MsgBox "has connected successfully"
NewClient = False
End If
＇获得数据
tcpClient.GetData sData
＇添加信息到文本框中
rtbIn.Text = rtbIn.Text + sData
rtbIn.SelStart = Len(sData)
＇判断是否为中断连接信息
If sData = "you can quit." Then
＇中断连接
tcpClient.Close
End If
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
    Case Is = "Connect"
        cmdConnect_Click
    Case Is = "Login"
        cmdLogin_Click
    Case Is = "Quit"
        cmdQuit_Click
    Case Is = "Save"
       cmdsave_Click
End Select
End Sub

在文本框中输入内容后回车开始发送信息，代码如下：
＇发送信息
 Private Sub txtOut_KeyUp(KeyCode As Integer, Shift As Integer)
On Error GoTo errhandle:
If KeyCode = 13 Then
tcpClient.SendData lblName.Caption + ":" + txtOut.Text
'rtbIn.Text = rtbIn.Text + txtOut.Text
txtOut.Text = ""
End If
Exit Sub
errhandle:
    MsgBox Err.Description
End Sub

Private Sub cmdOK_Click()
frmClient.txtHost = frmClientLogIn.txtserver.Text
frmClient.txtPort = frmClientLogIn.txtPorNum.Text
frmClient.lblName = frmClientLogIn.txtUserName
frmClient.cmdConnect.Enabled = True
frmClient.cmdQuit.Enabled = True
Unload frmClientLogIn 
End Sub


服务器端程序：
Dim Num As Integer
Dim flag As Boolean
'Dim member(1 To 10) As Integer
Dim NumOnline As Integer
Dim clientName(1 To 5)
Private Sub cmdLogin_Click()
Load frmServerLogIn
frmServerLogIn.Show
End Sub

设置Winsock控件的Protocols属性为sckTcpProtocol，载入窗体时显示服务器的信息，代码如下：
Private Sub Form_Load()
StatusBar1.Panels(1).Text = "Now there is nobody connected"
Num = 0
NumOnline = 0
＇设置本地端口
tcpServer(0).LocalPort = 5000   
＇开始监听
tcpServer(0).Listen   
＇显示服务器信息         
Label1.Caption = Label1.Caption + CStr(tcpServer(0).LocalIP)
Label3.Caption = Label3.Caption + CStr(tcpServer(0).LocalPort)
End Sub

Private Sub mnuBreak_Click()
For i = 1 To Num
    tcpServer(i).Close
    Next i
End Sub
Private Sub mnuExit_Click()
    response = MsgBox("要保存文件后再退出吗?", vbYesNo, "退出")
        If response = vbYes Then
         CommonDialog1.ShowSave
      rtbSave.SaveFile (CommonDialog1.FileName)
          End If
          End
End Sub

Private Sub mnuList_Click()
mnuList.Checked = Not mnuList.Checked
If mnuList.Checked Then
Toolbar1.Buttons("List").Value = tbrPressed
  Me.lstClient.ForeColor = RGB(0, 0, 0)
Else
Toolbar1.Buttons("List").Value = tbrUnpressed
 Me.lstClient.ForeColor = Me.lstClient.BackColor
End If
End Sub

Private Sub mnuOpen_Click()
 CommonDialog1.ShowOpen
        Load frmInspect
        frmInspect.rtbOpen.LoadFile (CommonDialog1.FileName)
        'frmInspect.rtbOpen.Visible = True
        frmInspect.Show
End Sub

Private Sub mnuSave_Click()
 CommonDialog1.ShowSave
      rtbSave.SaveFile (CommonDialog1.FileName)
End Sub

Private Sub mnuSend_Click()
mnuSend.Checked = Not mnuSend.Checked
TxtSend.Locked = Not TxtSend.Locked
End Sub

利用ConnectionRequest事件处理来自远程计算机的请求，代码如下：
Private Sub tcpServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)
'For i = 1 To Num
'If tcpServer.State <> sckClosed Then tcpServer.Close
'tcpServer(Num - 1).Accept requestID
'Next i
＇创建新的Socket，并连接
If Index = 0 Then
    Num = Num + 1
    NumOnline = NumOnline + 1
    Load tcpServer(Num)
      StatusBar1.Panels(1).Text = "There are " & NumOnline & "Client connected"
  'member(Num) = 1
     tcpServer(Num).LocalPort = 0
    tcpServer(Num).Accept requestID
    End If
End Sub

利用DataArrival事件处理来自远程计算机的新数据，代码如下：
Private Sub tcpServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim sData As String
Dim sName As String
＇接收数据
   tcpServer(Index).GetData sData
    'rtbSave.Text = sData
   rtbSave.SelStart = Len(rtbSave.Text)
＇获得第一个字符，判断信息类型
sName = Left(sData, 1)
＇/为请求连接的信息
If sName = "/" Then
    'rtbSave.SelLength = Len(rtbSave.Text)
    ＇添加用户登录信息
lstClient.AddItem sData + CStr(Now())
＇返回连接成功信息
tcpServer(Index).SendData "recieved successfully"
＇^为请求中断连接的信息
ElseIf sName = "^" Then
＇返回信息
tcpServer(Index).SendData "you can quit."
＇添加用户中断连接的信息
    lstClient.AddItem sData + CStr(Now())
    'lstClient.RemoveItem -1
  ' member(Index) = 0
   ＇中断连接
    tcpServer(Index).Close
    NumOnline = NumOnline - 1
     StatusBar1.Panels(1).Text = "There are " & NumOnline & "Client connected"
    rtbSave.SelStart = Len(rtbSave.Text)
       rtbSave.Text = rtbSave.Text + sData
End If
    ＇添加信息内容
    'rtbSave.SelStart = Len(rtbSave.Text)
    rtbSave.SelStart = Len(rtbSave.Text)
       rtbSave.Text = rtbSave.Text + sData
     txtout.Text = sData
rtbSave.SelStart = Len(rtbSave.Text)
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
   'Case "Connect"
       'cmdConnect_Click
    Case "Open"
        CommonDialog1.ShowOpen
        Load frmInspect
        
        frmInspect.rtbOpen.LoadFile (CommonDialog1.FileName)
        'frmInspect.rtbOpen.Visible = True
        frmInspect.Show
    Case "Quit"
          response = MsgBox("要保存文件后再退出吗?", vbYesNo, "退出")
        If response = vbYes Then
         CommonDialog1.ShowSave
      rtbSave.SaveFile (CommonDialog1.FileName)
          End If
          End
    Case "Save"
      CommonDialog1.ShowSave
      rtbSave.SaveFile (CommonDialog1.FileName)
    Case "List"
      mnuList_Click
      End Select
End Sub

Private Sub txtOut_Change()
For i = 1 To Num
If tcpServer(i).State <> sckClosed Then
    tcpServer(i).SendData txtout.Text
End If
Next i
End Sub
在文本框中输入内容，按回车键开始发送信息，代码如下：
Private Sub TxtSend_KeyUp(KeyCode As Integer, Shift As Integer)
＇判断是否为回车
If KeyCode = 13 Then
    For i = 1 To Num
       ' If member(i) = 0 Then
        ' Exit Sub
        'Else
　　　＇判断Socket连接状态
         If tcpServer(i).State = sckClosed Then
            Exit For
        Else
            ＇发送信息
            tcpServer(i).SendData "server:" & TxtSend.Text
            'rtbSave.Text = rtbSave.Text + TxtSend.Text
        End If
        Next i
        rtbSave.SelStart = Len(rtbSave.Text)
＇在文本框中添加内容
 rtbSave.Text = rtbSave.Text + Chr(10) + TxtSend.Text
TxtSend.Text = ""
End If
End Sub

Private Sub CmdOpen_Click()
On Error Resume Next
Me.CommonDialog1.ShowOpen
Me.rtbOpen.LoadFile Me.CommonDialog1.FileName
End Sub

Private Sub CmdReturn_Click()
Unload Me
frmServer.Show
End Sub