📄 tcpserver.frm
字号:
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 180
TabIndex = 15
Top = 4710
Width = 285
End
Begin VB.Label Label4
Caption = "表情:"
BeginProperty Font
Name = "楷体_GB2312"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 2115
TabIndex = 13
Top = 5115
Width = 660
End
Begin VB.Label Label3
Caption = "昵称:"
BeginProperty Font
Name = "楷体_GB2312"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 270
Left = 45
TabIndex = 11
Top = 5130
Width = 675
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "服务器端口"
Height = 180
Left = 6630
TabIndex = 7
Top = 645
Width = 885
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "服务器地址"
Height = 180
Left = 6615
TabIndex = 6
Top = 210
Width = 900
End
End
Attribute VB_Name = "FrmServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'==================================================================================
'
' 软件名称:局域网聊天室-服务器端
'
' 软件版本:1.0
'
' 网名:空间物体
'
' QQ:16811731
'
' Email:tjj1528@163.com
'
' 2004年6月10日与内蒙古工业大学信息工程学院316机房
'
'==================================================================================
Dim useid(30) As String
Dim nSock As Integer
Dim tcpNUM As Integer
Public a As String
Public bb As Boolean
Private Sub CmdClose_Click()
For i = 0 To nSock '关闭所有连接
If tcpServer(i).State <> sckClosed Then
tcpServer(i).Close
End If
Next i
SbarServer.Panels(1).Text = "服务器已经关闭"
FrmServer.CmdStart.Enabled = True
FrmServer.CmdClose.Enabled = False
TxtSend.Enabled = False
CmdSend.Enabled = False
Command1.Enabled = False
cmdcolor.Enabled = False
cmdserver.Enabled = False
Unload serverdata
tcpNUM = 0
SbarServer.Panels(2).Text = "当前有： 0 位在线"
End Sub
Private Sub cmdcolor_Click()
CommonDialog1.Action = 3
RTxtServer.BackColor = CommonDialog1.Color
End Sub
Private Sub cmdserver_Click()
If bb = True Then
Unload serverdata
bb = False
Else
serverdata.Show
bb = True
End If
End Sub
Private Sub CmdStart_Click()
List1.Clear
tcpServer(0).LocalPort = TxtPort.Text '设置本地端口
tcpServer(0).Listen
FrmServer.CmdStart.Enabled = False
FrmServer.CmdClose.Enabled = True
SbarServer.Panels(1).Text = "服务器准备就绪"
TxtIP.Enabled = False
TxtPort.Enabled = False
TxtSend.Enabled = False
CmdSend.Enabled = False
Command1.Enabled = True
cmdcolor.Enabled = True
cmdserver.Enabled = True
SbarServer.Panels(2).Text = "当前有： 0 位在线"
End Sub
Private Sub CmdSend_Click()
On Error GoTo errend
Select Case Combo1.Text
Case "不舍"
bq = "依依不舍地"
Case "微笑"
bq = "微微一笑"
Case "高兴"
bq = "兴高采烈地"
Case "歉意"
bq = "感到十二分的歉意,低声"
Case "挥手"
bq = "挥手"
Case "哈欠"
bq = "张大嘴巴,打了个哈欠"
Case "鞠躬"
bq = "毕恭毕敬地"
Case "深情"
bq = "用深情的眼神"
Case "鬼脸"
bq = "做了个鬼脸"
Case "大笑"
bq = "捧腹大笑"
Case "幸灾"
bq = "幸灾乐祸地"
Case "安慰"
bq = "双眼关切的"
Case "委屈"
bq = "很委屈地"
Case "沮丧"
bq = " 满脸沮丧地"
End Select
If TxtSend.Text <> "" Then
SbarServer.Panels(1).Text = "数据传输中............."
RTxtServer.SelStart = Len(RTxtServer.Text)
a = txtid.Text + "." + " " + bq + "对 " + Combouse.Text + " 说： " + TxtSend.Text + vbCrLf
Set rs = cn.Execute("insert into data (tcp_data) values ('" & a & "')")
RTxtServer.Text = RTxtServer.Text + vbCrLf + a
RTxtServer.SelStart = Len(RTxtServer.Text)
For i = 1 To nSock
If tcpServer(i).State <> sckClosed Then
tcpServer(i).SendData a
End If
Next i
TxtSend.Text = ""
TxtSend.SetFocus
SbarServer.Panels(1).Text = "数据传送完毕"
End If
Exit Sub
errend:
SbarServer.Panels(1).Text = "某客户机连接失败！无法发送数据！"
Exit Sub
End Sub
Private Sub Combo2_Click()
RTxtServer.Font.Size = Combo2.Text
End Sub
Private Sub Command1_Click()
On Error GoTo errend
CommonDialog1.ShowFont
RTxtServer.Font = CommonDialog1.FontName
' TxtServer.FontSize = CommonDialog1.FontSize
' TxtServer.FontBold = CommonDialog1.FontBold
' TxtServer.FontItalic = CommonDialog1.FontItalic
' TxtServer.FontStrikethru = CommonDialog1.FontStrikethru
' TxtServer.FontUnderline = CommonDialog1.FontUnderline
' TxtServer.ForeColor = CommonDialog1.Color
Exit Sub
errend:
MsgBox "没有字体可用"
Exit Sub
End Sub
Private Sub Form_Load()
Combo1.AddItem "不舍"
Combo1.AddItem "微笑"
Combo1.AddItem "高兴"
Combo1.AddItem "歉意"
Combo1.AddItem "挥手"
Combo1.AddItem "哈欠"
Combo1.AddItem "鞠躬"
Combo1.AddItem "深情"
Combo1.AddItem "鬼脸"
Combo1.AddItem "大笑"
Combo1.AddItem "幸灾"
Combo1.AddItem "安慰"
Combo1.AddItem "委屈"
Combo1.AddItem "沮丧"
Dim c(15) As ComboItem
Dim i As Integer
For i = 1 To 15
Set c(i) = ImageCombo1.ComboItems.Add(i, , , i, 0)
Next i
Call adddata
ImageCombo1.SelectedItem = c(1)
Combo1.ListIndex = 0
Combo2.ListIndex = 0
Combouse.ListIndex = 0
nSock = 0
tcpNUM = 0
TxtIP.Text = tcpServer(0).LocalIP '设置服务器IP
txtid.Text = tcpServer(0).LocalIP
FrmServer.TxtIP.Enabled = False
FrmServer.CmdClose.Enabled = False
SbarServer.Panels(1).Text = "准备启动服务器"
TxtSend.Enabled = False
CmdSend.Enabled = False
SbarServer.Panels(2).Text = "当前有： 0 位在线"
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub tcpServer_Close(Index As Integer)
SbarServer.Panels(1).Text = "客户端终止对话"
tcpServer(Index).Close
List1.RemoveItem (Val(tcpServer(Index)))
tcpNUM = tcpNUM - 1
SbarServer.Panels(2).Text = "当前有：" + CStr(tcpNUM) + "位在线"
If tcpNUM = 0 Then
TxtSend.Enabled = False
CmdSend.Enabled = False
End If
End Sub
Private Sub tcpServer_Connect(Index As Integer)
TxtSend.Enabled = True
CmdSend.Enabled = True
SbarServer.Panels(1).Text = "连接成功，服务器准备就绪"
SbarServer.Panels(2).Text = "当前有：" + CStr(tcpNUM) + "位在线"
TxtSend.Enabled = True
CmdSend.Enabled = True
TxtSend.SetFocus
End Sub
Private Sub tcpServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)
For i = 0 To List1.ListCount
If List1.List(i) = tcpServer(Index).RemoteHostIP Then
Else
List1.AddItem tcpServer(Index).RemoteHostIP
End If
Next i
'Combouse.AddItem
nSock = nSock + 1
tcpNUM = tcpNUM + 1
Load tcpServer(nSock)
tcpServer(nSock).LocalPort = 0
tcpServer(nSock).Accept requestID
SbarServer.Panels(1).Text = "接受客户机请求,连接建立成功"
SbarServer.Panels(2).Text = "当前有：" + CStr(tcpNUM) + "位在线"
TxtSend.Enabled = True
CmdSend.Enabled = True
End Sub
Private Sub tcpServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim clientDat As String
SbarServer.Panels(1).Text = "正在进行数据传输"
tcpServer(Index).GetData clientDat
If clientDat = "^" Then '客户端发来的如果是断开请求
tcpServer(Index).Close
tcpNUM = tcpNUM - 1
SbarServer.Panels(2).Text = "当前有：" + CStr(tcpNUM) + "位在线"
If tcpNUM = 0 Then
TxtSend.Enabled = False
CmdSend.Enabled = False
End If
Else
If Len(RTxtServer.Text) > 1024 Then RTxtServer.Text = ""
Set rs = cn.Execute("insert into data (tcp_data) values ('" & clientDat & "')")
RTxtServer.SelStart = Len(RTxtServer.Text)
RTxtServer.Text = RTxtServer.Text + vbCrLf + clientDat
RTxtServer.SelStart = Len(RTxtServer.Text)
For i = 1 To nSock
If tcpServer(i).State <> sckClosed And i <> Index Then
tcpServer(i).SendData clientDat
End If
Next i
End If
a = InStr(1, clientDat, ".")
b = Left(clientDat, a - 1)
c = Combouse.Text
For i = 0 To Combouse.ListCount - 1
Combouse.Text = Combouse.List(i)
If Combouse.Text = b Then d = True
Next i
If d = False Then Combouse.AddItem b
Combouse.Text = c
SbarServer.Panels(1).Text = "数据传送完毕"
End Sub
Private Sub tcpServer_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)
MsgBox "连接发生错误！启动服务器失败！", vbOKOnly + vbExclamation, "TCP 错误信息"
If tcpServer(Index).State <> sckClosed Then
tcpServer(Index).Close
End If
SbarServer.Panels(1).Text = "连接发生错误！"
TxtSend.Enabled = False
CmdSend.Enabled = False
End Sub
Private Sub tcpServer_SendComplete(Index As Integer)
SbarServer.Panels(1).Text = "数据传送完毕"
End Sub
Private Sub tcpServer_SendProgress(Index As Integer, ByVal bytesSent As Long, ByVal bytesRemaining As Long)
SbarServer.Panels(1).Text = "正在进行数据传输"
End Sub
Private Sub TxtSend_KeyDown(KeyCode As Integer, Shift As Integer)
On Error GoTo errend
If KeyCode = vbKeyReturn And TxtSend.Text <> "" Then
SbarServer.Panels(1).Text = "正在进行数据传输"
RTxtServer.SelStart = Len(RTxtServer.Text)
RTxtServer.Text = RTxtServer.Text + vbCrLf + txtid.Text + " " + bq + "对 " + Combouse.Text + " 说： " + TxtSend.Text + vbCrLf
RTxtServer.SelStart = Len(RTxtServer.Text)
For i = 1 To nSock
If tcpServer(i).State <> sckClosed Then
tcpServer(i).SendData txtid.Text + " " + bq + "对 " + Combouse.Text + " 说： " + TxtSend.Text + vbCrLf
End If
Next i
SbarServer.Panels(1).Text = "数据传送完毕"
TxtSend.Text = ""
TxtSend.SetFocus
End If
Exit Sub
errend:
SbarServer.Panels(1).Text = "某客户机连接失败！无法发送数据！"
Exit Sub
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -