📄 frmicqserver.frm
字号:
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmICQServer
Caption = "ICQ服务器"
ClientHeight = 6150
ClientLeft = 1155
ClientTop = 1185
ClientWidth = 9600
Icon = "frmICQServer.frx":0000
LinkTopic = "Form3"
ScaleHeight = 6150
ScaleWidth = 9600
Begin MSWinsockLib.Winsock wskServer
Index = 0
Left = 6720
Top = 1680
_ExtentX = 741
_ExtentY = 741
End
Begin VB.Frame Frame4
Caption = "服务器发送公共信息"
Height = 735
Left = 120
TabIndex = 8
Top = 5280
Width = 9375
Begin VB.CommandButton cmdPublic
Caption = "发送公共信息"
Height = 375
Left = 7680
TabIndex = 10
Top = 240
Width = 1575
End
Begin VB.TextBox txtPublic
Height = 375
Left = 120
TabIndex = 9
Text = "Text2"
Top = 240
Width = 7335
End
End
Begin VB.Frame Frame3
Caption = "服务器发送私有信息"
Height = 735
Left = 120
TabIndex = 5
Top = 4560
Width = 9375
Begin VB.CommandButton cmdPrivate
Caption = "发送私有信息"
Height = 375
Left = 7680
TabIndex = 7
Top = 240
Width = 1575
End
Begin VB.TextBox txtPrivate
Height = 375
Left = 120
TabIndex = 6
Text = "Text1按时反对"
Top = 240
Width = 7335
End
End
Begin VB.Frame fmeUser
Height = 4335
Left = 7680
TabIndex = 1
Top = 120
Width = 1815
Begin VB.CommandButton cmdDelOnlineUser
Caption = "在线用户删除"
Height = 375
Left = 120
TabIndex = 4
Top = 3840
Width = 1575
End
Begin VB.ListBox lstUsers
BackColor = &H80000007&
ForeColor = &H0000FF00&
Height = 3300
Left = 120
TabIndex = 3
Top = 240
Width = 1575
End
Begin VB.Label Label1
Caption = "(n) 为用户号"
Height = 255
Left = 600
TabIndex = 11
Top = 3600
Width = 1095
End
End
Begin VB.Frame Frame1
Caption = "事件查看"
Height = 4335
Left = 120
TabIndex = 0
Top = 120
Width = 7455
Begin VB.ListBox lstEventLog
ForeColor = &H00FF0000&
Height = 3840
Left = 120
TabIndex = 2
Top = 240
Width = 7215
End
End
Begin VB.Menu mnuFile
Caption = "文件(&F)"
Begin VB.Menu mnuFileAllUsers
Caption = "注册用户查询(&U)"
End
Begin VB.Menu as
Caption = "-"
End
Begin VB.Menu mnuFileExit
Caption = "退出(&X)"
End
End
End
Attribute VB_Name = "frmICQServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=============================================================================================
'|| ICQ服务器主窗体（启动模块） ||
'|| ||
'|| ICQ服务器主窗体负责整个服务器的通讯，主要完成下列功能： ||
'|| (1) 响应客户端用户的连接请求，并动态分配wskServer(n)接受； ||
'|| (2) 接收客户端的指令，并传给指令执行对象obtExecCommand； ||
'|| (3) 将指令执行完毕的结果发送给响应的客户端，并根据需要对服务器做相应调整； ||
'|| ||
'|| *注意：WinSock控件接受多用户连接的方法： ||
'|| 服务器端在设计时新建一WinSock控件，Index属性为0，其它WinSock控件数组中的元素 ||
'|| 在运行时根据动态链表队列（见clsWskChainQueue类模块）分配和回收。 ||
'|| 需要注意的是：wskServer(0)只能在Form_load中置为侦听状态，其他地方不可重置。 ||
'|| ||
'|| *注意：WinSock控件发送数据 ||
'|| 在WinSock控件发送之前置一个"发送未完成"标志，在SendData语句后，要用DoEvents语||
'|| 句循环直到"发送完成"标志的出现。在SendComplete事件中更改"发送未完成"标志为"发送完||
'|| 成"标志！ ||
'|| ||
'|| *注意：本窗体模块代码中的注释约定： ||
'|| 凡是WinSock 接收数据 的语句均用'---'注释 ||
'|| 凡是WinSock 发送数据 的语句均用'+++'注释 ||
'|| ||
'=============================================================================================
Option Explicit
Dim obtWskLink As clsWskChainQueue 'WinSock动态链表队列对象变量
Dim WithEvents obtExeCommand As clsWskCommandProcess '命令执行对象变量,只能定义一个
Attribute obtExeCommand.VB_VarHelpID = -1
Dim blnWskSendComplete As Boolean 'wskServer发送完成标志
Dim intAllUserNum As Integer '在线用户合计数
'=================================
' 在线用户删除
'=================================
Private Sub cmdDelOnlineUser_Click()
Dim strTp As String, strAccount As String
Dim intTp As Integer, intIdx As Integer
Dim msg
intIdx = lstUsers.ListIndex
strTp = lstUsers.List(intIdx)
If strTp = "" Then
MsgBox "在线用户列表中没有选中的用户！", 16, "ICQ服务器"
Else
msg = MsgBox("删除后，用户 " + strTp + " 将不能再进行通信！" + vbCrLf + "确实想强行删除在线用户 " + strTp + " 吗？（Y/N）", 36, "ICQ服务器")
If msg = vbNo Then Exit Sub
intTp = 1
Do '取用户号
intTp = intTp + 1
Loop Until Mid(Right(strTp, intTp), 1, 1) = "("
strAccount = Left(Right(strTp, intTp - 1), intTp - 2)
intTp = GetWskIdxBaseUserAccount(Val(strAccount))
lstEventLog.AddItem CStr(Now) + " 在线用户 " + strTp + " 被服务器强行删除！"
lstUsers.RemoveItem intIdx
intAllUserNum = intAllUserNum - 1
fmeUser.Caption = "在线用户(" + CStr(intAllUserNum) + "人)"
UnloadWskServer intTp
End If
End Sub
'=================================
' 发送私有信息
'=================================
Private Sub cmdPrivate_Click()
Dim strTp As String, strAccount As String
Dim intTp As Integer, intIdx As Integer
Dim msg
intIdx = lstUsers.ListIndex
strTp = lstUsers.List(intIdx)
If strTp = "" Then
MsgBox "在线用户列表中没有选中的用户！", 16, "ICQ服务器"
Else
intTp = 1
Do '取用户号
intTp = intTp + 1
Loop Until Mid(Right(strTp, intTp), 1, 1) = "("
strAccount = Left(Right(strTp, intTp - 1), intTp - 2)
intTp = GetWskIdxBaseUserAccount(Val(strAccount))
'+++++++++++++++++++++++\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
arrayLinkUser(intTp).blnSendComplete = False
On Error GoTo WSK_SERVER_ERR
wskServer(intTp).SendData UserSendString + txtPrivate.Text + CmdResultDiv _
+ CmdResultDiv + "ICQ服务器发给您的私有信息"
Do
DoEvents
Loop Until arrayLinkUser(intTp).blnSendComplete
'+++++++++++++++++++++++////////////////////////////////
lstEventLog.AddItem CStr(Now) + " ICQ服务器给用户 " + strTp + " 发送私有信息！"
End If
txtPrivate.Text = ""
Exit Sub
WSK_SERVER_ERR:
wskServerErr intTp
End Sub
'=================================
' 发送公共信息
'=================================
Private Sub cmdPublic_Click()
Dim intTp As Integer, intM As Integer
intM = UBound(arrayLinkUser)
For intTp = 1 To intM
With arrayLinkUser(intTp)
If .blnOnline Then
If Not .blnSendComplete Then '正在发送，服务器等待，直到以前内容发送完毕
Do
DoEvents
Loop Until .blnSendComplete
End If
'+++++++++++++++\\\\\\\\\\\\\\\\\\\\\
.blnSendComplete = False
On Error GoTo WSK_SERVER_ERR
wskServer(intTp).SendData UserSendString + txtPublic.Text + CmdResultDiv _
+ CmdResultDiv + "ICQ服务器给所有用户发送公共信息"
Do
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -