📄 tcpclient.frm
字号:
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 6405
TabIndex = 17
Top = 5115
Width = 630
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 = 60
TabIndex = 14
Top = 5130
Width = 675
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 = 5100
Width = 660
End
Begin VB.Label Label5
Caption = "对"
BeginProperty Font
Name = "楷体_GB2312"
Size = 14.25
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 135
TabIndex = 10
Top = 4740
Width = 285
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "服务器端口"
Height = 180
Left = 6630
TabIndex = 6
Top = 600
Width = 900
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "服务器地址"
Height = 180
Left = 6630
TabIndex = 5
Top = 210
Width = 900
End
End
Attribute VB_Name = "FrmClient"
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机房
'
'==================================================================================
Public bq As String
Public dd As Boolean
Private Sub cmdchat_Click()
If dd = True Then
Unload clientdata
dd = False
Else
clientdata.Show
dd = True
End If
End Sub
Private Sub CmdClose_Click()
tcpClient.SendData "^" '发断开信息给服务器
tcpClient.Close
SBarClient.Panels(1).Text = "连接已经断开"
CmdLink.Enabled = True
CmdClose.Enabled = False
CmdSend.Enabled = False
TxtSend.Enabled = False
TxtIP.Enabled = True
TxtPort.Enabled = True
fontcolor.Enabled = False
cmdchat.Enabled = False
cmdcolor.Enabled = False
Unload clientdata
End Sub
Private Sub cmdcolor_Click()
CommonDialog1.Action = 3
RTxtClient.BackColor = CommonDialog1.Color
End Sub
Private Sub CmdLink_Click()
tcpClient.RemoteHost = TxtIP.Text '设置服务器IP
tcpClient.RemotePort = TxtPort.Text '设置服务器端口
tcpClient.LocalPort = 0
tcpClient.Connect '连接服务器
SBarClient.Panels(1).Text = "正在连接服务器"
TxtIP.Enabled = False
TxtPort.Enabled = False
fontcolor.Enabled = True
cmdchat.Enabled = True
cmdcolor.Enabled = True
Exit Sub
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
SBarClient.Panels(1).Text = "正在进行数据传送"
TxtSend.Text = txtid.Text + "." + " " + bq + "对 " + combouse.Text + " 说： " + TxtSend.Text + vbCrLf
Set rs = cn.Execute("insert into data (tcp_data) values ('" & TxtSend.Text & "')")
tcpClient.SendData TxtSend.Text
TxtSend.Text = vbCrLf + TxtSend.Text
RTxtClient.SelStart = Len(RTxtClient.Text)
RTxtClient.Text = RTxtClient.Text + TxtSend.Text
RTxtClient.SelStart = Len(RTxtClient.Text)
TxtSend.Text = ""
TxtSend.SetFocus
SBarClient.Panels(1).Text = "数据传送完毕"
End If
Exit Sub
errend:
MsgBox "连接发生错误!数据发送失败！", vbOKOnly + vbExclamation, "TCP 错误信息"
SBarClient.Panels(1).Text = "连接失败！找不到服务器!"
CmdSend.Enabled = False
TxtSend.Enabled = False
TxtIP.Enabled = True
TxtPort.Enabled = True
Exit Sub
End Sub
Private Sub Combo2_Click()
RTxtClient.Font.Size = Combo2.Text
End Sub
Private Sub Command1_Click()
about.Show vbModal
End Sub
Private Sub fontcolor_Click()
CommonDialog1.Action = 3
RTxtClient.SelColor = CommonDialog1.Color
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 "沮丧"
Call adddata
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
ImageCombo1.SelectedItem = c(1)
combouse.ListIndex = 0
Combo1.ListIndex = 0
Combo2.ListIndex = 0
txtid = tcpClient.LocalIP
SBarClient.Panels(1).Text = "准备连接服务器"
CmdLink.Enabled = True
CmdClose.Enabled = False
CmdSend.Enabled = False
TxtSend.Enabled = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub tcpClient_Close()
If tcpClient.State <> sckClosed Then
tcpClient.Close
End If
SBarClient.Panels(1).Text = "连接失败!服务器已经关闭!"
CmdLink.Enabled = True
CmdClose.Enabled = False
CmdSend.Enabled = False
TxtSend.Enabled = False
TxtIP.Enabled = True
TxtPort.Enabled = True
End Sub
Private Sub tcpClient_Connect()
SBarClient.Panels(1).Text = "连接服务器成功，准备就绪"
CmdLink.Enabled = False
CmdClose.Enabled = True
CmdSend.Enabled = True
TxtSend.Enabled = True
TxtSend.SetFocus
TxtIP.Enabled = False
TxtPort.Enabled = False
End Sub
Private Sub tcpClient_DataArrival(ByVal bytesTotal As Long)
Dim serverDat As String
tcpClient.GetData serverDat, vbString
If Len(RTxtClient.Text) > 1024 Then
RTxtClient.Text = ""
End If
Set rs = cn.Execute("insert into data (tcp_data) values ('" & serverDat & "')")
RTxtClient.SelStart = Len(RTxtClient.Text)
RTxtClient.Text = RTxtClient.Text + vbCrLf + serverDat
'RTxtClient.OLEObjects.Add , , , " " & App.Path & "\pic\1.bmp"
'
' Picture1.Picture = LoadPicture("" & App.Path & "\pic\" & LTrim(Combo2.Text) & ".bmp")
' Clipboard.Clear
' Clipboard.SetData Picture1.Image
' RTxtClient.SetFocus
' SendKeys "^{V}"
'
RTxtClient.SelStart = Len(RTxtClient.Text)
a = InStr(1, serverDat, ".")
b = Left(serverDat, 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
End Sub
Private Sub tcpClient_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 "连接发生错误!找不到服务器！", vbOKOnly + vbExclamation, "TCP 错误信息"
If tcpClient.State <> sckClosed Then
tcpClient.Close
End If
SBarClient.Panels(1).Text = "连接失败！找不到服务器!"
CmdLink.Enabled = True
CmdClose.Enabled = False
CmdSend.Enabled = False
TxtSend.Enabled = False
TxtIP.Enabled = True
TxtPort.Enabled = True
End Sub
Private Sub tcpClient_SendComplete()
SBarClient.Panels(1).Text = "数据传送完毕"
End Sub
Private Sub tcpClient_SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
SBarClient.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
SBarClient.Panels(1).Text = "正在进行数据传送"
tcpClient.SendData TxtSend.Text
RTxtClient.SelStart = Len(RTxtClient.Text)
RTxtClient.Text = RTxtClient.Text + vbCrLf + txtid.Text + " " + bq + "对 " + combouse.Text + " 说： " + TxtSend.Text + vbCrLf
RTxtClient.SelStart = Len(RTxtClient.Text)
TxtSend.Text = ""
TxtSend.SetFocus
SBarClient.Panels(1).Text = "数据传送完毕"
End If
Exit Sub
errend:
MsgBox "连接发生错误!数据发送失败！", vbOKOnly + vbExclamation, "TCP 错误信息"
SBarClient.Panels(1).Text = "连接失败！找不到服务器!"
CmdLink.Enabled = True
CmdClose.Enabled = False
CmdSend.Enabled = False
TxtSend.Enabled = False
TxtIP.Enabled = True
TxtPort.Enabled = True
Exit Sub
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -