Option Explicit Private IgnoreText As Boolean '----------------------各控件说明 ---------------------------- '--名称-------------------------类型----------------------作用 ------------------ 'frmMain Form CHAT主窗体 'Winsock1 Winsock 连接控件 'Label1 Label CONNECT WITH IP标签 'Label2 Label LOCAL PORT标签 'Label3 Label REMOTE PORT标签 'txtRemoteIP TextBox 远程IP地址输入框 'txtLocalPort TextBox 本地PORT输入框 'txtRemotePort TextBox 远程PORT输入框 'cmdConnect CommandButton 连接CONNECT按钮 'Label4 Label Type your text and hit Enter to send it.标签 'Frame1(remoteip) Frame REMOTE IP 框架 'Frame2(host ip) Frame HOST IP 框架 'Text1 TextBox 显示对方(远程主机)发送的CHAT内容 'Text2 TextBox 输入己方(本地主机)要发送的CHAT内容,按ENTER键发送 'cmdClear CommandButton 清空输入框(TEXT2)和显示框(TEXT1)中的内容 'StatusBar1 StatusBar 状态栏 '----------------------------------------------------------- '当CLEAR按钮按下时,清空TEXT1和TEXT2中的内容 Private Sub cmdClear_Click() Text1 = "" With Text2 '清空输入框 .Text = " " '并把焦点置于TEXT2 .SetFocus End With End Sub '当CONNECT按钮按下时,进行以下操作 Private Sub cmdConnect_Click() On Error GoTo ErrHandler With Winsock1 '设置 RemoteHost 属性 .RemoteHost = Trim(txtRemoteIP) '设置 RemotePort 属性 'RemotePort 属性的值应该等于 远程主机上的 LocalHost 属性的值 .RemotePort = Trim(txtRemotePort) 'LocalPort 属性的值是不能改变的,必须检查它是否已经被设置 '如果 LocalPort 属性为空(没有被设置),将其设为在LocalPort输入框中输入的数值 If .LocalPort = Empty Then .LocalPort = Trim(txtLocalPort) Frame2.Caption = .LocalIP .Bind .LocalPort '待查 End If End With '为了保证使用者不能改变LocalPort的值,将txtLocalPort输入框锁定 txtLocalPort.Locked = True '在状态栏中显示“正在连接”的状态 StatusBar1.Panels(1).Text = " Connected to " & Winsock1.RemoteHost & " " '如果连接正常,做以下设置 Frame1.Enabled = True Frame2.Enabled = True Label4.Visible = True Text2.SetFocus Exit Sub '如果在连接过程中出现错误,则转向ErrHandler:,并显示错误提示 ErrHandler: MsgBox "Winsock Failed to establish connection with remote server",vbCritical End Sub '当按下“F1”键时显示帮助信息 Private Sub Form_KeyDown(KeyCode As Integer,Shift As Integer) If KeyCode = vbKeyF1 Then ChDir App.Path '调用外部程序notepad.exe来打开帮助文本文件 Shell "notepad.exe readme.txt",vbNormalFocus End If End Sub '当窗体加载时显示提示信息并在 txtRemoteIP 框中显示本地主机的IP Private Sub Form_Load() Show MsgBox "Winsock UDT Chat" & vbCrLf & "by Theo Kandiliotis (ionikh@hol.gr)" & vbCrLf & vbCrLf & "F1 for help.",vbInformation txtRemoteIP = Winsock1.LocalIP End Sub '接收TEXT2输入框的按键,并做响应 Private Sub Text2_KeyPress(KeyAscii As Integer) '定义变量 Last_Line_Feed 来记录最后输入行的位置 Static Last_Line_Feed As Long '定义 New_Line 字符串记录新键入的一行文本的内容 Dim New_Line As String '如果使用者按下CLEAR按钮对输入框内容清空,这时TEXT2为空,则重设最后输入行的位置为0 If Trim(Text2) = vbNullString Then Last_Line_Feed = 0 '当使用者按下ENTER键时 If KeyAscii = 13 Then '取得最后输入行的内容并赋值给 New_Line 字符串 New_Line = Mid(Text2,Last_Line_Feed + 1) '重设最后输入行的位置 Last_Line_Feed = Text2.SelStart '通过 WINSOCK 发送新输入的一行文本的内容 Winsock1.SendData New_Line '在状态栏显示发送信息 StatusBar1.Panels(2).Text = " Sent " & (LenB(New_Line) / 2) & " bytes " End If End Sub '当 WINSOCK 接收到新的数据(信息)时,进行以下响应 Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) '定义 New_Text 字符串来记录新接收的信息 Dim New_Text As String '接收信息并赋值给 New_Text Winsock1.GetData New_Text '在TEXT1显示框中显示新接收到的信息 Text1.SelText = New_Text Frame1.Caption = Winsock1.RemoteHostIP '在状态栏中显示接收信息 StatusBar1.Panels(2).Text = " Recieved " & bytesTotal & " bytes " End Sub '--------------------------------------------------------------------------- '这就是一个最简单的CHAT程序,你可以在它的基础上加以改进,做出更实用的CHAT小软件。 '--------------------------------------------------------------------------- 我收集的一个例子能实现用户列表功能: 服务器端代码: Option Explicit Private Const LOCAL_PORT = 9999 '设置端口号为9999 Private Const MAX_NUM = 9 '设置Winsock控件数组的上界 Dim idxuser(MAX_NUM) As String '该变量用于存放用户名 Sub DeleUser(idx As Integer) Dim i As Integer Dim flag As Boolean '在用户名列表中查找指定的用户名 '记录其在用户名列表框中的索引值 For i = 0 To lstUserName.ListCount - 1 '如果查到,则设置标记变量flag为真,并跳出循环, '此时变量i的值就是,要查找的用户名的索引值 If idxuser(idx) = lstUserName.List(i) Then flag = True Exit For Else flag = False End If Next i '如果flag为真,则删除索引值为i的列表项 If flag Then lstUserName.RemoveItem i End If End Sub Sub SendUserList() Dim i As Integer Dim j As Integer '向所有客户端发送用户列表 For i = 1 To MAX_NUM With wsk(i) '如果状态为连接状态,则把所有用户名列表项 '一条一条的传送给客户端,每个用户名前都加@2标记 '以便让客户端知道传送的是用户名 If .State = sckConnected Then For j = 0 To lstUserName.ListCount - 1 .SendData "@2" & lstUserName.List(j) DoEvents Next j '发送用户名列表传送结束标记 .SendData "@e" End If End With Next i End Sub Sub RefreshStatus() Dim i As Integer Dim actnum As Integer '检查Winsock控件数组中,有几个控件是连接状态, '并且用变量actnum保存具有连接状态的控件的个数 For i = 1 To MAX_NUM With wsk(i) If .State = sckConnected Then actnum = actnum + 1 End If End With Next i '设置状态栏第一个窗格内的值为变量actnum的值 With stsBar .Panels(1).Text = "在线人数:" & Str(actnum) End With End Sub Private Sub Form_Load() Dim i As Integer '设置Winsock控件wsk(0)的协议和端口 wsk(0).Protocol = sckTCPProtocol wsk(0).LocalPort = LOCAL_PORT '让wsk(0)监听端口 wsk(0).Listen '加载9个Winsocks控件,并分别设置其协议和端口 For i = 1 To MAX_NUM Load wsk(i) wsk(i).Protocol = sckTCPProtocol wsk(i).LocalPort = LOCAL_PORT Next '调用refreshStatus过程,刷新状态栏 Call RefreshStatus End Sub Private Sub Form_Resize() '设置窗体中控件的大小和位置 If Me.WindowState <> vbMinimized Then lstUserName.Top = 10 lstUserName.Left = Me.ScaleWidth - lstUserName.Width - 10 lstUserName.Height = Me.ScaleHeight - Me.stsBar.Height lstMess.Move 10,10,Me.ScaleWidth - lstUserName.Width - 10,Me.ScaleHeight - Me.stsBar.Height End If End Sub Private Sub mnuFileExit_Click() Unload Me End Sub Private Sub mnuFileSave_Click() Dim i As Integer Open "聊天记录.txt" For Append As #1 For i = 0 To lstMess.ListCount - 1 Print #1,lstMess.List(i) Next i MsgBox "保存成功!",vbOKOnly + vbInformation,"提示" Close #1 '关闭文件 End Sub Private Sub tmrRefreshSTS_Timer() '每隔1秒钟,刷新状态栏 Call RefreshStatus End Sub Private Sub wsk_Close(Index As Integer) wsk(Index).Close '与客户端断开,刷新状态栏 Call RefreshStatus '从用户列表删除连接断开的客户端 Call DeleUser(Index) '向所有客户端传送新的用户列表 Call SendUserList End Sub Private Sub wsk_Connect(Index As Integer) '连接成功,则刷新状态栏 Call RefreshStatus End Sub Private Sub wsk_ConnectionRequest(Index As Integer,ByVal requestID As Long) Dim msg As String Dim i As Integer If Index = 0 Then '查寻Winsock控件数组中,没有连接客户端 '的控件,并将客户端的连入请求分配给数组中 '下标值最小的空闲Winsock控件 For i = 1 To MAX_NUM With wsk(i) If .State = sckClosed Then '接收连入请求 .Accept requestID '跳出循环 Exit For End If End With Next End If End Sub Private Sub wsk_DataArrival(Index As Integer,ByVal bytesTotal As Long) Dim msg As String Dim i As Integer Dim flag As Boolean '使用变量msg保存传输过来的信息 wsk(Index).GetData msg,bytesTotal '判断传输过来的是用户名还是聊天信息 '如果以@+开头则是用户名,否则是聊天信息 If Left(msg,2) = "@+" Then '判断是否到达聊天用户上线,如果是则发送@# If lstUserName.ListCount = MAX_NUM - 1 Then wsk(Index).SendData "@#" Exit Sub End If '将真正的用户名从字符串msg中分离出来 msg = Mid(msg,3) For i = 0 To lstUserName.ListCount - 1 '判断传输过来的用户名是否已经在用户名列表中 '如果在列表中,则设置标记变量flag为真 '并跳出循环,否则设置为假 If msg = lstUserName.List(i) Then flag = True Exit For Else flag = False End If Next i '如果标记为真,则传送用户名已经存在标记@1, '并断开连接,如果为假则将用户名添加到用户名列表中, '并用窗体级数组变量idxuser存放用户名,其中idxuser的 '下标Index就是Winsock控件数组的下标Index If flag Then wsk(Index).SendData "@1" Else lstUserName.AddItem msg idxuser(Index) = msg '向所有客户端传送用户列表 Call SendUserList End If Else '将聊天信息添加到列表框内 lstMess.AddItem msg '将聊天信息发送到其他客户端(聊友) For i = 1 To MAX_NUM With wsk(i) If .State = sckConnected Then '将聊天信息发送给具体的客户端 .SendData msg '等待信息被发送出去 DoEvents End If End With Next End If End Sub 客户端主窗口代码: Option Explicit Private Sub Form_Resize() '设置窗体中控件的大小和位置 If Me.WindowState <> vbMinimized Then fraUserName.Top = 10 fraUserName.Left = Me.ScaleWidth - fraUserName.Width - 10 fraUserName.Height = Me.ScaleHeight - 10 lstUserName.Height = fraUserName.Height - 300 fraMess.Top = 10 fraMess.Left = 10 fraMess.Height = Me.ScaleHeight - fraSend.Height - 10 lstMess.Height = fraMess.Height - 300 fraMess.Width = Me.ScaleWidth - fraUserName.Width - 50 lstMess.Width = fraMess.Width - 300 fraSend.Top = fraMess.Height + 20 fraSend.Left = 10 fraSend.Width = fraMess.Width txtSendData.Width = fraSend.Width - 300 End If End Sub Private Sub Form_Unload(Cancel As Integer) Unload frmLogin End Sub Private Sub txtSendData_KeyPress(KeyAscii As Integer) If KeyAscii = 13 Then If frmLogin.wsk1.State = sckConnected Then frmLogin.wsk1.SendData Now & " " & frmLogin.G_myname & "对" & _ Me.lstUserName.Text & _ "说:" & txtSendData.Text txtSendData.Text = "" Else MsgBox "目前没有连接服务器!" End If End If End Sub 客户端登录窗口代码: Option Explicit Public G_myname As String Dim flag As Boolean Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String,ByVal lpWindowName As String) As Long Public Function IsShow(FormName As String) As Boolean '该函数用于判断窗体是否已经显示 '如果显示则返回真,否则返回假 Dim X As Long X = FindWindow(vbNullString,FormName) If X <> 0 Then IsShow = True Else IsShow = False End If End Function Private Sub cmdLogin_Click() '连接服务器 wsk1.Connect End Sub Private Sub Form_Load() '设置服务器的IP地址,其中127.0.0.1代表本地 '计算机,即与客户端程序运行在同一台机器上 ' wsk1.RemoteHost = "127.0.0.1" wsk1.RemotePort = 9999 flag = False End Sub Private Sub wsk1_Connect() '连接成功后,马上发送用户名 wsk1.SendData "@+" & txtUserName.Text End Sub Private Sub wsk1_DataArrival(ByVal bytesTotal As Long) Dim msg As String Dim username As String '使用msg存放传送过来的信息 wsk1.GetData msg,bytesTotal '判断传送过来的信息是何种信息,头两个字符为@#, '表明聊天室用户已到上线,头两个字符为@1, '则传递过来的是用户名已存在,拒绝连接的信息 '头两个字符为@2,则表明传过来的是用户名列表的内容, '头两个字符为@e,则表明用户名列表传送结束 '除以上标记以外的,则表明传过来的是聊天信息 Select Case Left(msg,2) Case "@#" wsk1.Close MsgBox "聊天室已满!请稍候登录!" Exit Sub Case "@1" wsk1.Close MsgBox "您输入的用户名已经存在!请使用其他用户名" txtUserName.Text = "" txtUserName.SetFocus Exit Sub Case "@2" '判断标记变量flag是否为真, '如果为真,则清楚用户名列表内的 '内容,以达到避免重复添加用户名 If flag Then frmMain.lstUserName.Clear flag = False End If '用变量username存放真正的用户名信息 username = Mid(msg,3) '将用户名信息添加到用户名列表框中 frmMain.lstUserName.AddItem username Case "@e" '用户名列表传送结束,将flag设置为真 flag = True Case Else '将信息添加到聊天内容列表框 frmMain.lstMess.AddItem msg End Select '判断frmMain窗体是否显示,如果没有显示 '则显示该窗体,并隐藏登录窗体, '给全局变量G_myname赋值,否则如果以显示 '则将其设置为可见 If IsShow("聊天客户端") = False Then G_myname = txtUserName.Text frmMain.Caption = "聊天室客户端程序" & "--我的用户名:" & G_myname frmMain.Show Me.Hide Else G_myname = txtUserName.Text frmMain.Caption = "聊天室客户端程序" & "--我的用户名:" & G_myname frmMain.Visible = True Me.Hide End If End Sub Private Sub wsk1_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 "出现错误!" & vbCrLf & _ "错误号为:" & Number & vbCrLf & _ "错误描述为:" & Description & vbCrLf End Sub