Option Explicit Private IgnoreText As Boolean '----------------------各控件说明 ---------------------------- '--<a href="/tag/mingcheng/" target="_blank" class="keywords">名称</a>-------------------------类型----------------------作用 ------------------ 'frmMain Form CHAT主窗体 'Winsock1 Winsock 连接控件 'Label1 Label CONNECT WITH IP<a href="/tag/biaoqian/" target="_blank" class="keywords">标签</a> 'Label2 Label LOCAL PORT<a href="/tag/biaoqian/" target="_blank" class="keywords">标签</a> 'Label3 Label REMOTE PORT<a href="/tag/biaoqian/" target="_blank" class="keywords">标签</a> 'txtRemoteIP Text<a href="/tag/Box/" target="_blank" class="keywords">Box</a> 远程IP地址输入框 'txtLocalPort Text<a href="/tag/Box/" target="_blank" class="keywords">Box</a> 本地PORT输入框 'txtRemotePort Text<a href="/tag/Box/" target="_blank" class="keywords">Box</a> 远程PORT输入框 'cmdConnect CommandButton 连接CONNECT按钮 'Label4 Label Type your text and hit Enter to send it.<a href="/tag/biaoqian/" target="_blank" class="keywords">标签</a> 'Frame1(remoteip) Frame REMOTE IP 框架 'Frame2(host ip) Frame HOST IP 框架 'Text1 Text<a href="/tag/Box/" target="_blank" class="keywords">Box</a> <a href="/tag/xianshi/" target="_blank" class="keywords">显示</a>对方（远程主机）发送的CHAT<a href="/tag/neirong/" target="_blank" class="keywords">内容</a> 'Text2 Text<a href="/tag/Box/" target="_blank" class="keywords">Box</a> 输入己方（本地主机）要发送的CHAT<a href="/tag/neirong/" target="_blank" class="keywords">内容</a>，按ENTER键发送 'cmdClear CommandButton 清空输入框（TEXT2）和<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a>框（TEXT1）中的<a href="/tag/neirong/" target="_blank" class="keywords">内容</a> 'StatusBar1 StatusBar 状态栏 '----------------------------------------------------------- '当CLEAR按钮按下时，清空TEXT1和TEXT2中的<a href="/tag/neirong/" target="_blank" class="keywords">内容</a> 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 <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a> .RemoteHost = Trim(txtRemoteIP) '设置 RemotePort <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a> 'RemotePort <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a>的值应该等于 远程主机上的 LocalHost <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a>的值 .RemotePort = Trim(txtRemotePort) 'LocalPort <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a>的值是不能改变的,必须检查它是否已经被设置 '如果 LocalPort <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a>为空（没有被设置），将其设为在LocalPort输入框中输入的数值 If .LocalPort = Empty Then .LocalPort = Trim(txtLocalPort) Frame2.Caption = .LocalIP .Bind .LocalPort '待查 End If End With '为了保证使用者不能改变LocalPort的值，将txtLocalPort输入框锁定 txtLocalPort.Locked = True '在状态栏中<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a>“正在连接”的状态 StatusBar1.Panels(1).Text = " Connected to " & Winsock1.RemoteHost & " " '如果连接正常，做以下设置 Frame1.Enabled = True Frame2.Enabled = True Label4.Visible = True Text2.SetFocus Exit Sub '如果在连接过程中出现<a href="/tag/cuowu/" target="_blank" class="keywords">错误</a>，则转向ErrHandler:，并<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a><a href="/tag/cuowu/" target="_blank" class="keywords">错误</a><a href="/tag/tishi/" target="_blank" class="keywords">提示</a> ErrHandler: Msg<a href="/tag/Box/" target="_blank" class="keywords">Box</a> "Winsock <a href="/tag/Failed/" target="_blank" class="keywords">Failed</a> to establish connection with remote server",vbCritical End Sub '当按下“F1”键时<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a>帮助信息 Private Sub Form_KeyDown(KeyCode As Integer,Shift As Integer) If KeyCode = vbKeyF1 Then ChDir App.Path '<a href="/tag/diaoyong/" target="_blank" class="keywords">调用</a>外部程序notepad.exe来打开帮助文本<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a> Shell "notepad.exe readme.txt",vbNormalFocus End If End Sub '当窗体加载时<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a><a href="/tag/tishi/" target="_blank" class="keywords">提示</a>信息并在 txtRemoteIP 框中<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a>本地主机的IP Private Sub Form_Load() Show Msg<a href="/tag/Box/" target="_blank" class="keywords">Box</a> "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_<a href="/tag/Feed/" target="_blank" class="keywords">Feed</a> 来记录最后输入行的位置 Static Last_Line_<a href="/tag/Feed/" target="_blank" class="keywords">Feed</a> As Long '定义 New_Line 字符串记录新键入的一行文本的<a href="/tag/neirong/" target="_blank" class="keywords">内容</a> Dim New_Line As String '如果使用者按下CLEAR按钮对输入框<a href="/tag/neirong/" target="_blank" class="keywords">内容</a>清空，这时TEXT2为空，则重设最后输入行的位置为0 If Trim(Text2) = vbNullString Then Last_Line_<a href="/tag/Feed/" target="_blank" class="keywords">Feed</a> = 0 '当使用者按下ENTER键时 If KeyAscii = 13 Then '取得最后输入行的<a href="/tag/neirong/" target="_blank" class="keywords">内容</a>并赋值给 New_Line 字符串 New_Line = Mid(Text2,Last_Line_<a href="/tag/Feed/" target="_blank" class="keywords">Feed</a> + 1) '重设最后输入行的位置 Last_Line_<a href="/tag/Feed/" target="_blank" class="keywords">Feed</a> = Text2.SelStart '通过 WINSOCK 发送新输入的一行文本的<a href="/tag/neirong/" target="_blank" class="keywords">内容</a> Winsock1.SendData New_Line '在状态栏<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a>发送信息 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<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a>框中<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a>新接收到的信息 Text1.SelText = New_Text Frame1.Caption = Winsock1.RemoteHostIP '在状态栏中<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a>接收信息 StatusBar1.Panels(2).Text = " Recieved " & bytesTotal & " bytes " End Sub '--------------------------------------------------------------------------- '这就是一个最简单的CHAT程序，你可以在它的基础上加以改进，做出更实用的CHAT小软件。 '--------------------------------------------------------------------------- 我收集的一个例子能实现<a href="/tag/yonghu/" target="_blank" class="keywords">用户</a>列表<a href="/tag/gongneng/" target="_blank" class="keywords">功能</a>: 服务器端<a href="/tag/daima/" target="_blank" class="keywords">代码</a>: Option Explicit Private Const LOCAL_PORT = 9999 '设置端口号为9999 Private Const MAX_NUM = 9 '设置Winsock控件数组的上界 Dim idxuser(MAX_NUM) As String '该变量用于存放<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a> Sub DeleUser(idx As Integer) Dim i As Integer Dim flag As Boolean '在<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>列表中查找指定的<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a> '记录其在<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>列表框中的索引值 For i = 0 To lstUserName.ListCount - 1 '如果查到，则设置<a href="/tag/biaoji/" target="_blank" class="keywords">标记</a>变量flag为真，并跳出循环， '此时变量i的值就是，要查找的<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>的索引值 If idxuser(idx) = lstUserName.List(i) Then flag = True Exit For Else flag = False End If Next i '如果flag为真，则<a href="/tag/shanchu/" target="_blank" class="keywords">删除</a>索引值为i的列表项 If flag Then lstUserName.RemoveItem i End If End Sub Sub SendUserList() Dim i As Integer Dim j As Integer '向所有客户端发送<a href="/tag/yonghu/" target="_blank" class="keywords">用户</a>列表 For i = 1 To MAX_NUM With wsk(i) '如果状态为连接状态，则把所有<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>列表项 '一条一条的传送给客户端，每个<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>前都加@2<a href="/tag/biaoji/" target="_blank" class="keywords">标记</a> '以便让客户端知道传送的是<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a> If .State = sckConnected Then For j = 0 To lstUserName.ListCount - 1 .SendData "@2" & lstUserName.List(j) DoEvents Next j '发送<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>列表传送结束<a href="/tag/biaoji/" target="_blank" class="keywords">标记</a> .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 '<a href="/tag/diaoyong/" target="_blank" class="keywords">调用</a>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 Msg<a href="/tag/Box/" target="_blank" class="keywords">Box</a> "保存成功！",vbOKOnly + vbInformation,"<a href="/tag/tishi/" target="_blank" class="keywords">提示</a>" Close #1 '<a href="/tag/guanbi/" target="_blank" class="keywords">关闭</a><a href="/tag/wenjian/" target="_blank" class="keywords">文件</a> End Sub Private Sub tmrRefreshSTS_Timer() '每隔1秒钟，刷新状态栏 Call RefreshStatus End Sub Private Sub wsk_Close(Index As Integer) wsk(Index).Close '与客户端断开，刷新状态栏 Call RefreshStatus '从<a href="/tag/yonghu/" target="_blank" class="keywords">用户</a>列表<a href="/tag/shanchu/" target="_blank" class="keywords">删除</a>连接断开的客户端 Call DeleUser(Index) '向所有客户端传送新的<a href="/tag/yonghu/" target="_blank" class="keywords">用户</a>列表 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 '判断传输过来的是<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>还是聊天信息 '如果以@+开头则是<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>，否则是聊天信息 If Left(msg,2) = "@+" Then '判断是否到达聊天<a href="/tag/yonghu/" target="_blank" class="keywords">用户</a>上线，如果是则发送@# If lstUserName.ListCount = MAX_NUM - 1 Then wsk(Index).SendData "@#" Exit Sub End If '将真正的<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>从字符串msg中分离出来 msg = Mid(msg,3) For i = 0 To lstUserName.ListCount - 1 '判断传输过来的<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>是否已经在<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>列表中 '如果在列表中，则设置<a href="/tag/biaoji/" target="_blank" class="keywords">标记</a>变量flag为真 '并跳出循环，否则设置为假 If msg = lstUserName.List(i) Then flag = True Exit For Else flag = False End If Next i '如果<a href="/tag/biaoji/" target="_blank" class="keywords">标记</a>为真，则传送<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>已经存在<a href="/tag/biaoji/" target="_blank" class="keywords">标记</a>@1， '并断开连接，如果为假则将<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a><a href="/tag/tianjia/" target="_blank" class="keywords">添加</a>到<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>列表中， '并用窗体级数组变量idxuser存放<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>，其中idxuser的 '下标Index就是Winsock控件数组的下标Index If flag Then wsk(Index).SendData "@1" Else lstUserName.AddItem msg idxuser(Index) = msg '向所有客户端传送<a href="/tag/yonghu/" target="_blank" class="keywords">用户</a>列表 Call SendUserList End If Else '将聊天信息<a href="/tag/tianjia/" target="_blank" class="keywords">添加</a>到列表框内 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 客户端主窗口<a href="/tag/daima/" target="_blank" class="keywords">代码</a>: 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 Msg<a href="/tag/Box/" target="_blank" class="keywords">Box</a> "目前没有连接服务器！" End If End If End Sub 客户端<a href="/tag/denglu/" target="_blank" class="keywords">登录</a>窗口<a href="/tag/daima/" target="_blank" class="keywords">代码</a>: 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 '该<a href="/tag/hanshu/" target="_blank" class="keywords">函数</a>用于判断窗体是否已经<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a> '如果<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a>则返回真，否则返回假 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() '连接成功后，马上发送<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a> 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 '判断传送过来的信息是何种信息，头两个字符为@#， '表明聊天室<a href="/tag/yonghu/" target="_blank" class="keywords">用户</a>已到上线，头两个字符为@1， '则传递过来的是<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>已存在，拒绝连接的信息 '头两个字符为@2，则表明传过来的是<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>列表的<a href="/tag/neirong/" target="_blank" class="keywords">内容</a>， '头两个字符为@e，则表明<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>列表传送结束 '除以上<a href="/tag/biaoji/" target="_blank" class="keywords">标记</a>以外的，则表明传过来的是聊天信息 Select Case Left(msg,2) Case "@#" wsk1.Close Msg<a href="/tag/Box/" target="_blank" class="keywords">Box</a> "聊天室已满！请稍候<a href="/tag/denglu/" target="_blank" class="keywords">登录</a>！" Exit Sub Case "@1" wsk1.Close Msg<a href="/tag/Box/" target="_blank" class="keywords">Box</a> "您输入的<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>已经存在！请使用其他<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>" txtUserName.Text = "" txtUserName.SetFocus Exit Sub Case "@2" '判断<a href="/tag/biaoji/" target="_blank" class="keywords">标记</a>变量flag是否为真， '如果为真，则清楚<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>列表内的 '<a href="/tag/neirong/" target="_blank" class="keywords">内容</a>，以达到避免重复<a href="/tag/tianjia/" target="_blank" class="keywords">添加</a><a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a> If flag Then frmMain.lstUserName.Clear flag = False End If '用变量username存放真正的<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>信息 username = Mid(msg,3) '将<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>信息<a href="/tag/tianjia/" target="_blank" class="keywords">添加</a>到<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>列表框中 frmMain.lstUserName.AddItem username Case "@e" '<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>列表传送结束，将flag设置为真 flag = True Case Else '将信息<a href="/tag/tianjia/" target="_blank" class="keywords">添加</a>到聊天<a href="/tag/neirong/" target="_blank" class="keywords">内容</a>列表框 frmMain.lstMess.AddItem msg End Select '判断frmMain窗体是否<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a>，如果没有<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a> '则<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a>该窗体，并隐藏<a href="/tag/denglu/" target="_blank" class="keywords">登录</a>窗体， '给<a href="/tag/quanjubianliang/" target="_blank" class="keywords">全局变量</a>G_myname赋值,否则如果以<a href="/tag/xianshi/" target="_blank" class="keywords">显示</a> '则将其设置为可见 If IsShow("聊天客户端") = False Then G_myname = txtUserName.Text frmMain.Caption = "聊天室客户端程序" & "--我的<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>：" & G_myname frmMain.Show Me.Hide Else G_myname = txtUserName.Text frmMain.Caption = "聊天室客户端程序" & "--我的<a href="/tag/yonghuming/" target="_blank" class="keywords">用户名</a>：" & 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) Msg<a href="/tag/Box/" target="_blank" class="keywords">Box</a> "出现<a href="/tag/cuowu/" target="_blank" class="keywords">错误</a>！" & vbCrLf & _ "<a href="/tag/cuowu/" target="_blank" class="keywords">错误</a>号为:" & Number & vbCrLf & _ "<a href="/tag/cuowu/" target="_blank" class="keywords">错误</a>描述为：" & Description & vbCrLf End Sub