📄 frmserver.frm
字号:
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmServer
BorderStyle = 1 'Fixed Single
Caption = "聊天室Server 制作：陈德嘉"
ClientHeight = 6885
ClientLeft = 1965
ClientTop = 795
ClientWidth = 8160
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
KeyPreview = -1 'True
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 6885
ScaleWidth = 8160
Begin VB.ComboBox Combo1
BackColor = &H00C0C000&
Height = 360
Left = 480
Style = 2 'Dropdown List
TabIndex = 7
Top = 6360
Width = 1455
End
Begin VB.CommandButton Command1
Caption = "发送"
Default = -1 'True
Height = 375
Left = 6600
TabIndex = 6
Top = 6360
Width = 1335
End
Begin VB.TextBox Text2
Height = 375
Left = 2520
TabIndex = 5
Top = 6360
Width = 3975
End
Begin VB.HScrollBar HScroll1
Height = 250
LargeChange = 100
Left = 180
Max = 620
SmallChange = 10
TabIndex = 4
Top = 5992
Width = 6015
End
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 5885
Left = 200
ScaleHeight = 5820
ScaleWidth = 5970
TabIndex = 1
Top = 120
Width = 6035
Begin VB.VScrollBar VScroll1
Height = 5825
LargeChange = 24
Left = 5675
Max = 24
Min = 24
TabIndex = 3
Top = 0
Value = 24
Width = 300
End
Begin VB.TextBox Text1
ForeColor = &H00808000&
Height = 5900
Left = -50
Locked = -1 'True
MultiLine = -1 'True
TabIndex = 2
Top = -50
Width = 12000
End
End
Begin VB.ListBox List1
BackColor = &H00C0C000&
ForeColor = &H00000000&
Height = 5820
Left = 6360
TabIndex = 0
Top = 360
Width = 1575
End
Begin MSWinsockLib.Winsock sckListen
Left = 1800
Top = 2280
_ExtentX = 741
_ExtentY = 741
_Version = 393216
RemoteHost = "f4"
End
Begin MSWinsockLib.Winsock sckServer
Index = 0
Left = 3120
Top = 2160
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin MSWinsockLib.Winsock sckBusy
Left = 2520
Top = 2280
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.Label Label1
BackColor = &H00D38F3D&
BorderStyle = 1 'Fixed Single
Caption = " 0人在线"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Left = 6360
TabIndex = 10
Top = 120
Width = 1575
End
Begin VB.Label Label2
Caption = "对："
Height = 255
Left = 120
TabIndex = 9
Top = 6420
Width = 495
End
Begin VB.Label Label3
Caption = "说："
Height = 255
Left = 2040
TabIndex = 8
Top = 6420
Width = 615
End
End
Attribute VB_Name = "frmServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim Hig As Long
Dim con As Integer
Dim userIP() As String
Dim user() As String '在线名单
Dim userState() As Integer '-1 请求退出 0 离线 1 正常在线 2 只能看不能发言 3 正在被踢 4 客户端非正常终止
Dim zxrs As Integer '在线人数
Private Sub Command1_Click()
Dim index As Integer
Dim S As String
Dim recUser As String
S = Trim(Text2.Text)
Text2.Text = ""
recUser = Combo1.Text
If recUser = "所有人" Then
If S = "SystemOrder:boot" Then
For i = 0 To MaxChan - 1
userState(i) = 3
Next
End If
Call SendToAll(S)
Else
index = FindSckIndex(recUser)
If S = "SystemOrder:boot" Then userState(index) = 3
Call SendToOne(S, index)
End If
S = "对" & recUser & "说：" & S
Call AddToText1(S)
End Sub
Private Sub Form_Load()
ReDim userState(MaxChan)
ReDim user(MaxChan)
ReDim userIP(MaxChan)
Dim i As Integer
Hig = 24
zxrs = 0
For i = 1 To MaxChan - 1
Load sckServer(i)
Next i
sckListen.LocalPort = 1000
sckListen.Listen
Combo1.AddItem "所有人"
Combo1.ListIndex = 0
End Sub
Private Sub HScroll1_Change()
Text1.Left = -50 - HScroll1.Value * 10
End Sub
Private Sub List1_Click()
MsgBox sckServer(FindSckIndex(List1.List(List1.ListIndex))).RemoteHostIP & " " & sckServer(FindSckIndex(List1.List(List1.ListIndex))).RemotePort
End Sub
Private Sub sckBusy_Close()
sckBusy.Close
End Sub
Private Sub sckBusy_DataArrival(ByVal bytesTotal As Long)
sckBusy.SendData "SystemOrder:服务器忙，请稍后再连接！"
DoEvents
End Sub
Private Sub sckListen_ConnectionRequest(ByVal requestID As Long)
Dim i As Integer
'决定由哪一Winsock接受请求
For i = 0 To MaxChan - 1
If sckServer(i).State = 0 Then
Exit For
End If
Next i
If i = MaxChan Then
sckBusy.Close
sckBusy.Accept requestID
Exit Sub
End If
If sckServer(i).State = 0 Then
sckServer(i).Accept requestID
Exit Sub
End If
'如果所有Winsock都用完则由专门的“忙”Winsock接受请求，以免用户要求得不到响应
End Sub
Private Sub sckListen_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)
sckListen.Close
sckListen.LocalPort = 1000
sckListen.Listen
End Sub
Private Sub sckServer_Close(index As Integer)
If userState(index) = 1 Then userState(index) = -1 '客户端请求退出
Call Stop_sckServer(index, userState(index))
End Sub
Private Sub sckServer_DataArrival(index As Integer, ByVal bytesTotal As Long)
Dim S As String
Dim ss As String
Dim i As Integer
Dim recUser As String
Dim senUser As String
Dim senIP As String
sckServer(index).GetData S '接收信息到 s
If userState(index) = 0 Then '如果是刚进来，winsock尚未使用的话
senUser = Trim(S)
senIP = sckServer(index).RemoteHostIP
If InStr(1, senUser, "*") = 1 Then
senUser = Right(senUser, Len(senUser) - 1)
Else
If checkUserName(senUser) = 1 Then
Call SendToOne("SystemOrder:姓名重复，客户端退出重进！", index)
Exit Sub
End If
If checkUserIP(senIP) = 1 Then
Call SendToOne("SystemOrder:IP重复，客户端退出重进！", index)
Exit Sub
End If
End If
S = "～～～～～～欢迎 " & senUser & " 进入聊天室！～～～～～～～"
userState(index) = 1 '设置用户状态为正常在线
user(index) = senUser
userIP(index) = senIP
List1.AddItem user(index) '加入到在线列表
Combo1.AddItem user(index)
zxrs = zxrs + 1
Label1.Caption = " " & zxrs & "人在线"
Call SendToAllExcept("SystemOrder:addtolist" & user(index) & "038868", index)
For i = 0 To List1.ListCount - 1
ss = ss & List1.List(i) & "038868"
Next
Call SendToOne("SystemOrder:addtolist" & ss, index)
End If
If InStr(1, S, "038868SendToOne") = 0 Then
Call SendToAll(S) '广播方式
Else
recUser = Left(S, InStr(1, S, "038868SendToOne") - 1)
S = Right(S, Len(S) - Len(recUser) - Len("038868SendToOne"))
Call SendToOne(S, FindSckIndex(recUser))
If user(index) <> recUser Then Call SendToOne(S, index)
End If
'将所发信息也写入服务器
Call AddToText1(S)
End Sub
Private Sub sckServer_Error(index As Integer, 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)
userState(index) = 4 '客户端非正常终止
Call Stop_sckServer(index, userState(index))
End Sub
'利用winsock的State属性给所有连接在服务器上的客户发消息
Private Sub SendToAll(msg As String)
For i = 0 To MaxChan - 1
If sckServer(i).State = 7 Then
sckServer(i).SendData Trim(msg)
DoEvents
End If
Next i
End Sub
'给某个人发信息
Private Sub SendToOne(msg As String, index As Integer)
If sckServer(index).State = 7 Then
sckServer(index).SendData msg
DoEvents
End If
End Sub
Private Sub SendToAllExcept(msg As String, index As Integer)
For i = 0 To MaxChan - 1
If sckServer(i).State = 7 And index <> i Then
sckServer(i).SendData Trim(msg)
DoEvents
End If
Next i
End Sub
Private Sub AddToText1(S As String)
hang = Len(S)
con = con + 1
If con > 24 Then
Text1.Height = Text1.Height + 5760 / 24
VScroll1.Min = VScroll1.Min + 1
Text1.Top = Text1.Top - 5760 / 24
End If
Text1.Text = Text1.Text & S & Chr(13) & Chr(10)
End Sub
Private Sub VScroll1_Change()
ChangHeight = VScroll1.Value - Hig
Text1.Top = Text1.Top + ChangHeight * (5760 / 24)
Hig = VScroll1.Value
End Sub
Private Function FindSckIndex(UserName As String)
For i = 0 To MaxChan - 1
If user(i) = UserName Then Exit For
Next
FindSckIndex = i
End Function
Private Function checkUserIP(IP As String) As Integer
checkUserIP = 0
For i = 0 To MaxChan - 1
If userIP(i) = IP Then
checkUserIP = 1
Exit For
End If
Next
End Function
Private Function checkUserName(UserName As String) As Integer
checkUserName = 0
For i = 0 To MaxChan - 1
If user(i) = UserName Then
checkUserName = 1
Exit For
End If
Next
End Function
Private Sub Stop_sckServer(index As Integer, State As Integer) 'State=－1 正常终止 'State>0 非正常终止
Dim S As String
sckServer(index).Close
If userState(index) <> 0 Then
zxrs = zxrs - 1 '在线人数减一
Label1.Caption = " " & zxrs & "人在线"
S = "～～～～～～" & user(index) & "未知原因被终止！～～～～～～"
If State = -1 Then S = "～～～～～～" & user(index) & " 退出聊天室～～～～～～"
If State = 3 Then S = "～～～～～～" & user(index) & " 被管理员踢出聊天室～～～～～～"
If State = 4 Then S = "～～～～～～" & user(index) & " 非正常退出！～～～～～～"
Call SendToAll(S)
DoEvents
Call SendToAll("SystemOrder:removefromlist" & user(index))
For i = 0 To List1.ListCount - 1
If List1.List(i) = user(index) Then Exit For
Next
List1.RemoveItem i '从在线名单上删除退出者
Combo1.RemoveItem i + 1
Combo1.ListIndex = 0
user(index) = "" '清除退出者姓名记录
userIP(index) = "" '清除退出者IP记录
userState(index) = 0 '设置用户状态为离线
Call AddToText1(S)
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -