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
http://blog.csdn.net/laotou99/article/details/6046336
