利用Winsock控件创建的局域网聊天程序

1.服务器端往服务器窗体（命名为frmServer）添加三个控件，分别为LIST1（存放在线好友名单），text1（留言内容）和text2（聊天记录），程序如下：Option ExplicitConst Busy As Boolean = FalseConst Free As Boolean = TrueDim ConnectState() As BooleanDim SIndexDim Usrs(0 To 32) 在线人名Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) EndEnd SubPrivate Sub Form_Load() If App.PrevInstance = True Then MsgBox 程序已在运行, vbCritical End End If ReDim Preserve ConnectState(0) On Error Resume Next ConnectState(0) = Free Listener.LocalPort = 1001 端口号 Listener.Listen 开始侦听End SubPrivate Sub Listener_ConnectionRequest(ByVal requestID As Long) Dim SockIndex As Integer Dim SockNum As Integer On Error Resume Next SockNum = UBound(ConnectState) If SockNum 32 Then Exit Sub 查找空闲的SckServer SockIndex = FindFreeSocket 如果已有的sock都忙，而且sock数不超过32个，动态添加sock If SockIndex SockNum Then Load SckServer(SockIndex) ConnectState(SockIndex) = Busy SckServer(SockIndex).Tag = SockIndex 接受请求 SckServer(SockIndex).Accept (requestID)End SubPrivate Sub SckServer_DataArrival(Index As Integer, ByVal bytesTotal As Long) Dim dx As String SIndex = Index SckServer(Index).GetData dx, vbString If Len(Text2.Text) = 512 Then Text2.Text = If Right(dx, 2) = | Then List1.AddItem Replace(dx, |, ) Usrs(SIndex) = Replace(dx, |, ) Timer1.Enabled = True Text2.Text = Format(Now(), YY-MM-DD hh:mm:ss) & “ & Usrs(Index) & ”上线。 & vbCrLf & Text2.Text Open App.Path & record.txt For Append As #1 Write #1, Format(Now(), YY-MM-DD hh:mm:ss) & “ & Usrs(Index) & ”上线。 Close #1 Else Text1.Text = Left(dx, InStr(dx, |) & Format(Now(), YY-MM-DD hh:mm:ss) & vbCrLf & Usrs(Index) & 说： & Right(dx, Len(dx) - InStr(dx, |) Text2.Text = Format(Now(), YY-MM-DD hh:mm:ss) & “ & Usrs(Index) & ”对“ & Replace(dx, |, ”说： & vbCrLf) & vbCrLf & Text2.Text Open App.Path & record.txt For Append As #1 Write #1, Format(Now(), YY-MM-DD hh:mm:ss) & “ & Usrs(Index) & ”对“ & Replace(dx, |, ”说： & vbCrLf) Close #1 End IfEnd SubPrivate Sub SckServer_Close(Index As Integer) Dim i% On Error Resume Next If SckServer(Index).State sckClosed Then SckServer(Index).Close ConnectState(Index) = Free Text2.Text = Format(Now(), YY-MM-DD hh:mm:ss) & “ & Usrs(Index) & ”下线。 & vbCrLf & Text2.Text Open App.Path & record.txt For Append As #1 Write #1, Format(Now(), YY-MM-DD hh:mm:ss) & “ & Usrs(Index) & ”下线。 Close #1 For i = 0 To List1.ListCount If List1.List(i) = Usrs(Index) Then List1.RemoveItem (i) Usrs(Index) = Timer1.Enabled = True Exit For End If NextEnd SubPublic Function FindFreeSocket() Dim SockCount, i As Integer SockCount = UBound(ConnectState) For i = 0 To SockCount If ConnectState(i) = Free Then FindFreeSocket = i Exit Function End If Next i ReDim Preserve ConnectState(0 To SockCount + 1) FindFreeSocket = UBound(ConnectState)End FunctionPrivate Sub Text1_Change() Dim Ar, i On Error GoTo L1 Ar = Split(Text1.Text, |) For i = 0 To UBound(Usrs) If Usrs(i) = Ar(0) And Ar(0) Then Exit For Next SckServer(i).SendData Text1.TextL1:End SubPrivate Sub Timer1_Timer() Dim i%, j%, Str$ For j = 0 To List1.ListCount Str = Str & List1.List(j) & | Next On Error Resume Next For i = 0 To UBound(ConnectState) SckServer(i).SendData Str NextL1: Str = Timer1.Enabled = FalseEnd Sub2.客户端客户端工程里添加两个窗体（Login和frmClient），分别如图所示，把登陆窗体存放用户名的文本框命名为USRN。程序代码如下（示范，没什么实际意义）：Private Sub Form_Load() If App.PrevInstance = True Then MsgBox 程序已在运行, vbCritical End End If Usrn.Text = UCase(Environ(UserName)End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) EndEnd SubPrivate Sub Command1_Click() Me.Hide frmClient.ShowEnd SubPrivate Sub Command2_Click() Usrn.Text = Text2.Text = End SubPrivate Sub Command3_Click() EndEnd Sub在对话窗体（frmClient）中添加三个对象，List1用于存放在线好友名单，单击选中要交谈的好友，Txtsend输入要发送的信息，txtOutput显示收到的信息。Connect按钮用于重新连接服务器。程序如下：Const ComputerName = 你的计算机名字或IP地址Private Sub Form_Load() Winsock 控件的名字为SckClient。注意：要指定远程主机，可以使用 IP 地址（例如：121.111.1.1），也可以使用计算机的“好听的名字”。 SckClient.RemoteHost = ComputerName SckClient.RemotePort = 1001 SckClient.Connect cmdConnect.Enabled = SckClient.State = sckClosed Me.Caption = Me.Caption & - & Login.Usrn.TextEnd SubPrivate Sub cmdConnect_Click() 调用Connect 方法，初始化连接。 If SckClient.State sckClosed Then SckClient.Close SckClient.Connect cmdConnect.Enabled = SckClient.State = sckClosedEnd SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) EndEnd SubPrivate Sub Command1_Click() MsgBox List1.Text On Error GoTo L1 If List1.Text = Then Exit Sub SckClient.SendData List1.Text & | & txtSend.Text txtOutput.Text = Format(Now(), YY-MM-DD hh:mm:ss) & vbCrLf & 对 & List1.Text & 说： & txtSend.Text & vbCrLf & vbCrLf & txtOutput.Text txtSend.Text = Exit SubL1: MsgBox 通信失败 cmdConnect.Enabled = TrueEnd SubPrivate Sub List1_Click() If List1.Text Login.Usrn.Text Then Speakto.Caption = 对 & List1.Text & 说： Else MsgBox 你选择了自己。 End IfEnd SubPrivate Sub SckClient_DataArrival(ByVal bytesTotal As Long) Dim strData As String, ar, i% SckClient.GetData strData, vbString If Len(txtOutput.Text) 512 Then txtOutput.Text = If Right(strData, 2) = | Then List1.Clear ar = Split(strData, |) For i = 0 To UBound(ar) If ar(i) Then Li