📄 server.frm
字号:
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
End
Begin VB.Frame Frame9
Appearance = 0 'Flat
BackColor = &H00EBF5F4&
ForeColor = &H80000008&
Height = 615
Left = 0
TabIndex = 38
Top = 7650
Width = 9780
Begin VB.CommandButton cmdBlockedUsers
BackColor = &H00EBF5F4&
Height = 420
Left = 7880
Picture = "Server.frx":6EB7
Style = 1 'Graphical
TabIndex = 57
ToolTipText = "更新用户列表"
Top = 150
Width = 495
End
Begin VB.CommandButton cmdhelp
BackColor = &H00EBF5F4&
Height = 420
Left = 9120
Picture = "Server.frx":72F7
Style = 1 'Graphical
TabIndex = 43
ToolTipText = "帮助"
Top = 150
Width = 495
End
Begin VB.PictureBox namecolor
BackColor = &H00800000&
Height = 255
Left = 1515
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 42
ToolTipText = "用户名颜色"
Top = 220
Width = 255
End
Begin VB.PictureBox messagecolor
BackColor = &H00BF1AA3&
Height = 255
Left = 1860
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 41
ToolTipText = "信息颜色"
Top = 220
Width = 255
End
Begin VB.PictureBox hypercolor
BackColor = &H00C00000&
Height = 255
Left = 2235
ScaleHeight = 195
ScaleWidth = 195
TabIndex = 40
ToolTipText = "URL 颜色"
Top = 220
Width = 255
End
Begin VB.CommandButton cmdupdclientlist
BackColor = &H00EBF5F4&
Height = 420
Left = 8520
Picture = "Server.frx":8701
Style = 1 'Graphical
TabIndex = 39
ToolTipText = "更新用户列表"
Top = 150
Width = 495
End
Begin MSComDlg.CommonDialog cd
Left = 3240
Top = 120
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Label Label7
BackStyle = 0 'Transparent
Caption = "改变颜色"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 255
Index = 1
Left = 120
TabIndex = 44
Top = 240
Width = 1215
End
Begin VB.Label Label7
BackStyle = 0 'Transparent
Caption = "Change Colors"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 0
Left = 130
TabIndex = 52
Top = 250
Visible = 0 'False
Width = 1215
End
End
Begin VB.Menu opt
Caption = "选项"
Begin VB.Menu mkick
Caption = "Kick"
End
Begin VB.Menu msendmsg
Caption = "Send Message"
End
Begin VB.Menu mkop
Caption = "Make Op"
End
Begin VB.Menu dop
Caption = "De Op"
End
Begin VB.Menu wrn
Caption = "Warn"
End
End
End
Attribute VB_Name = "Server"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************************************************
' ：） 人人为我，我为人人 ：）
'枕善居汉化收藏整理
'发布日期：05/08/03
'描 述：我的网络聊天室(服务器端)
'网 站：http://www.mndsoft.com/
'e-mail ：mnd@mndsoft.com
'OICQ ：88382850
'****************************************************************************
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_PASTE = &H302
Dim start As Integer
Dim newstart As Integer
'color variables
Dim name_color, message_color, hyper_color As OLE_COLOR
'put your nick
Dim nick As String
' USERLIST TAG =
' NAME TAG =
'DECLARATIONS
Dim PORTNO As Long 'LISTEN PORT OF SERVER
Dim CLIENTNO As Integer
Dim CONNCLIENTNO As Integer 'CONNECTED CLIENT NO
Dim USERLIST As String
Dim USERLISTIP As String
'GET MESSAGE FROM USERS
Dim MESSAGE As String
'FOR COLORING TEXT
Dim POS_START As Integer
Dim FIND_POS As Integer
Dim i As Integer
Dim serverindex As Integer
Private Sub clearchat_Click()
txtchat.Text = ""
newstart = 0
End Sub
Private Sub cmdBlockedUsers_Click()
BlockedList.Show
End Sub
Private Sub cmddisconnect_Click()
'关闭所有套接字
Dim i As Integer
For i = 1 To tcpserver.Count - 1
tcpserver_Close i
Unload tcpserver(i)
Next
cmddisconnect.Enabled = False
cmdlisten.Enabled = True
lblclientsconn.Caption = 1
PORTNO = CLng(txtportno.Text)
lblstatus.Caption = "侦听中 "
shpstatus.FillColor = vbRed
txtchat.SelText = "服务器关闭."
End Sub
Private Sub cmdhelp_Click()
MsgBox "欢迎光临枕善居. 请访问本站获取更多的信息.", vbOKOnly
End Sub
Private Sub cmdlisten_Click()
On Error Resume Next
txtchat.SelText = vbCrLf & vbCrLf & vbCrLf
txtchat.SelText = "启动服务器" & vbTab & ": " & txtservername.Text & " ..." & vbCrLf
txtchat.SelText = vbCrLf & "启动时间 " & vbTab & ": " & Time & vbCrLf
txtchat.SelText = "端口 " & vbTab & ": 10000" & vbCrLf & vbCrLf
txtchat.SelText = "服务器启动成功." & vbCrLf
lblstatus.Caption = "侦听中 "
shpstatus.FillColor = vbGreen
cmdlisten.Enabled = False
cmddisconnect.Enabled = True
txtmessage.SetFocus
txtmessage.SelStart = Len(txtmessage.Text)
End Sub
Private Sub cmdsend_Click()
'Set SelStart = 0 to copy the text from start
txtmessage.SelStart = 0
'Set lenght upto the length of txtmessage
txtmessage.SelLength = Len(txtmessage.Text)
'Set SelStart = length of txtchat
txtchat.SelStart = Len(txtchat.Text)
'copy the contents to txtchat
newstart = Len(txtchat.Text)
txtchat.SelStart = newstart
txtchat.SelText = txtmessage.SelRTF
'send data immediately
BROADCAST txtmessage.Text
txtchat.SelText = vbCrLf
'color the text in txtchat
'COLORTEXT
'detect hyperlink
'DETECT_HYPERLINK
'clear and set the start of typing
txtmessage.Text = ""
txtmessage.SelStart = Len(txtmessage.Text)
'restore factory defaults
txtmessage.SelColor = vbBlack
txtmessage.SelUnderline = False
End Sub
Private Sub cmdupdclientlist_Click()
SEND_USER_LIST_TO_ALL_CLIENTS
End Sub
Private Sub dop_Click()
On Error Resume Next
tcpserver(lstusersnumber.List(lstusers.LISTINDEX)).SendData "DOU:"
End Sub
Private Sub Form_Load()
txtservername.Text = GetIPHostName
txtipaddress.Text = GetIPAddress
'ADD YOUR NAME TO USER LIST
lstusers.AddItem txtservername.Text
'INPUT MESSAGE FOR STARTING PORT NUMBER FROM THE SERVER
Dim listenportstartfrom As String
listenportstartfrom = InputBox("请输入端口号." & vbCrLf & vbCrLf & "不要使用系统保留的端口号," & vbCrLf & vbCrLf & " Http" & vbTab & "=" & vbTab & "80,8080" & vbCrLf & " Ftp" & vbTab & "=" & vbTab & "1080" & vbCrLf & " Smtp" & vbTab & "=" & vbTab & "25" & vbCrLf & vbCrLf & "提示: 端口号小于50000" & vbCrLf, "提示")
PORTNO = CLng(listenportstartfrom)
txtportno.Text = PORTNO
serverindex = 0
tcpserver(0).LocalPort = txtportno
tcpserver(0).Listen
nick = txtservername.Text
txtmessage.Text = nick & " >> "
End Sub
Private Sub lstusers_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 2 And lstusers.LISTINDEX <> 0 Then
Me.PopupMenu opt
End If
End Sub
Private Sub hypercolor_Click()
'cd.ShowColor
'hypercolor.BackColor = cd.Color
'hyper_color = hypercolor.BackColor
End Sub
Private Sub messagecolor_Click()
'cd.ShowColor
'messagecolor.BackColor = cd.Color
'message_color = messagecolor.BackColor
End Sub
Private Sub mkop_Click()
On Error Resume Next
tcpserver(lstusersnumber.List(lstusers.LISTINDEX)).SendData "MUO:"
End Sub
Private Sub namecolor_Click()
'cd.ShowColor
'namecolor.BackColor = cd.Color
'name_color = namecolor.BackColor
End Sub
Private Sub mkick_Click()
'kick all the instances of user
KICK_USER lstusers.List(lstusers.LISTINDEX)
End Sub
Private Sub Timer1_Timer()
cmdupdclientlist_Click
End Sub
Private Sub wrn_Click()
On Error Resume Next
tcpserver(lstusersnumber.List(lstusers.LISTINDEX)).SendData "WU:"
End Sub
Private Sub tcpserver_Close(Index As Integer)
On Error Resume Next
Dim ClientName As String
ClientName = lstusers.List(Index)
For i = 1 To lstusers.ListCount - 1
If lstusers.List(i) = ClientName Then
'tcpserver(lstusersnumber.List(i)).Close
'tcpserver(lstusersnumber.List(i)).Listen
Unload tcpserver(i)
lstusers.RemoveItem (i)
lstusersnumber.RemoveItem (i)
CLIENTNO = CLIENTNO - 1
lblclientsconn.Caption = CONNCLIENTNO
i = i - 1
End If
Next
BROADCAST_TO_ALL_NETWORKS ClientName & " leave the chat"
SEND_USER_LIST_TO_ALL_CLIENTS
End Sub
Private Sub tcpserver_ConnectionRequest(Index As Integer, ByVal requestID As Long)
On Error Resume Next
'ACCEPT REQUEST OF NEW CLIENT
If Index = 0 Then
CLIENTNO = CLIENTNO + 1
serverindex = serverindex + 1
Load tcpserver(serverindex)
tcpserver(serverindex).LocalPort = "10000"
tcpserver(serverindex).Accept requestID
End If
'SEND YOUR NAME TO CLIENT
tcpserver(serverindex).SendData "⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -