📄 form1.frm
字号:
VERSION 5.00
Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "shdocvw.dll"
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1
BorderStyle = 3 'Fixed Dialog
Caption = "Form1"
ClientHeight = 6525
ClientLeft = 45
ClientTop = 330
ClientWidth = 8145
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6525
ScaleWidth = 8145
StartUpPosition = 1 '所有者中心
Begin VB.CommandButton Command4
Caption = "登录"
Height = 495
Left = 2640
TabIndex = 13
Top = 5640
Width = 1215
End
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
Height = 495
Left = 1800
ScaleHeight = 435
ScaleWidth = 2835
TabIndex = 12
Top = 2640
Visible = 0 'False
Width = 2895
End
Begin VB.Timer Timer2
Interval = 10000
Left = 2400
Top = 5640
End
Begin VB.Timer Timer1
Interval = 1000
Left = 1560
Top = 5640
End
Begin MSComctlLib.StatusBar StatusBar1
Align = 2 'Align Bottom
Height = 375
Left = 0
TabIndex = 11
Top = 6150
Width = 8145
_ExtentX = 14367
_ExtentY = 661
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 2
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 7144
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 7144
EndProperty
EndProperty
End
Begin VB.CommandButton Command3
Caption = "退出"
Height = 495
Left = 5160
TabIndex = 10
Top = 5640
Width = 1095
End
Begin VB.TextBox Text2
Height = 375
Left = 6600
TabIndex = 9
Top = 5280
Width = 1455
End
Begin MSWinsockLib.Winsock Winsock1
Left = 7320
Top = 5760
_ExtentX = 741
_ExtentY = 741
_Version = 393216
RemotePort = 2001
End
Begin VB.CommandButton Command2
Caption = "刷屏"
Height = 495
Left = 0
TabIndex = 8
Top = 5640
Width = 1215
End
Begin VB.CheckBox Check1
Caption = "私聊"
Height = 255
Left = 6600
TabIndex = 7
Top = 4920
Width = 735
End
Begin VB.ListBox List1
Height = 4470
ItemData = "Form1.frx":0000
Left = 6600
List = "Form1.frx":0002
Style = 1 'Checkbox
TabIndex = 4
Top = 360
Width = 1455
End
Begin VB.CommandButton Command1
Caption = "发送"
Height = 495
Left = 5160
TabIndex = 3
Top = 4920
Width = 1095
End
Begin VB.TextBox Text1
Height = 495
Left = 1320
TabIndex = 1
Top = 4920
Width = 3735
End
Begin SHDocVwCtl.WebBrowser WebBrowser1
Height = 4455
Left = 0
TabIndex = 0
Top = 360
Width = 6375
ExtentX = 11245
ExtentY = 7858
ViewMode = 0
Offline = 0
Silent = 0
RegisterAsBrowser= 0
RegisterAsDropTarget= 1
AutoArrange = 0 'False
NoClientEdge = 0 'False
AlignLeft = 0 'False
ViewID = "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
Location = "res://C:\WINNT\system32\shdoclc.dll/dnserror.htm#http:///"
End
Begin VB.Label Label3
AutoSize = -1 'True
Caption = "聊天者列表："
Height = 180
Left = 6600
TabIndex = 6
Top = 120
Width = 1080
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "聊天内容："
Height = 180
Left = 120
TabIndex = 5
Top = 120
Width = 900
End
Begin VB.Label Label1
BorderStyle = 1 'Fixed Single
Caption = "发言：（支持简单HTML语言）"
Height = 480
Left = 0
TabIndex = 2
Top = 4920
Width = 1320
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim OldItem As Integer
Dim Mytime As Integer
Private Sub Check1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 0 Then
If (X < 0) Or (Y < 0) Or (X > Check1.Width) Or (Y > Check1.Height) Then
Picture1.Visible = False
ReleaseCapture
Else
SetCapture Check1.hwnd
With Picture1
.Visible = True
.Left = X + Check1.Left - 1500
.Top = Y + Check1.Top - 700
End With
End If
End If
End Sub
'用来表示以前被选中的项目
Private Sub Command1_Click()
If Check1.Value = 0 Then
Winsock1.SendData "~in~" & "|" & "~ev~" & "|" & LenInfo(Text1) & Text1
'我们约定:
'“~in~”为在聊天室内标志
'“~ev~”为和所有人聊天标志
'“|”为分隔标志
'FinLen 和InfoLen为两个返回长度的函数
Open App.Path & "\" & "mychat.htm" For Append As #1
Print #1, "<p>" & "<font color=blue>自己对大家说：</font>" & Text1 & "</font>"
'多加一个“</font>”以防止用户忘记添加而给后来聊天者造成影响
Close #1
'写入文件
WebBrowser1.Navigate App.Path & "\mychat.htm"
'WebBrowser1.Refresh
'X = SendMessage(WebBrowser1.hwnd, WM_HSCROLL, SB_RIGHT, ByVal 0&)
'浏览器刷新
End If
If Check1.Value = 1 Then
Winsock1.SendData "~in~" & "|" & "~on~" & "|" & Text2 & "|" & LenInfo(Text1) & Text1
'Text2中用来放置私聊名单
Open App.Path & "\" & "mychat.htm" For Append As #1
Print #1, "<p>" & "<font color=blue>自己对" & Text2 & "说：</font>" & Text1 & "</font>"
Close #1
WebBrowser1.Navigate App.Path & "\mychat.htm"
'WebBrowser1.Refresh
X = SendMessage(WebBrowser1.hwnd, WM_HSCROLL, SB_RIGHT, ByVal 0&)
End If
End Sub
Private Sub Command2_Click()
'清空文件，并刷新浏览器
Open App.Path & "\mychat.htm" For Output As #1
Close #1
WebBrowser1.Refresh
End Sub
Private Sub Command3_Click()
Winsock1.SendData "~in~" & "|" & "~wo~" & "|" & LenInfo(NowUser) & nowserinfo
'发送退出请求
'约定“~wo~”为退出标志
End Sub
Private Sub Command4_Click()
frmLogin.Show
End Sub
Private Sub Form_Load()
Command1.Enabled = False
Command2.Enabled = False
Command3.Enabled = False
Mytime = 0
OldItem = -1
'没有项目被选中
WebBrowser1.Navigate "about:blank"
'置空浏览器
Picture1.Print "如果要私聊，请选中私聊选项，"
Picture1.Print "并在聊天者列表中选择要私聊的人。"
End Sub
Private Sub List1_ItemCheck(Item As Integer)
If OldItem <> -1 Then
'判断以前有没有被选中的项目
List1.Selected(OldItem) = False
Text2 = List1.List(Item)
Else
Text2 = List1.List(Item)
End If
OldItem = Item
'ListBox控件没有项目单击事件，所以我们用这种方法来确定列表中哪一个被选中，
'此时ListBox控件的style属性必须设置为“1 - CheckBox”
End Sub
Private Sub Timer1_Timer()
Select Case Winsock1.State
Case 0:
StatusBar1.Panels(2).Text = "关闭"
Case 7:
StatusBar1.Panels(2).Text = "通信中"
Case 6:
StatusBar1.Panels(2).Text = "正在连接"
Case 9:
StatusBar1.Panels(2).Text = "错误"
Case Else
End Select
StatusBar1.Panels(1).Text = "聊天者状态："
End Sub
Private Sub Timer2_Timer()
Mytime = Mytime + 1
If Mytime = 6 Then
'一分钟请求一次名单
Mytime = 0
Winsock1.SendData "~in~" & "|" & "~aw~"
End If
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim MyData, FirF, ToName, ToInfo
Dim MyLenF, MyLenS As Integer
Dim MyLenF1, MyLenS1 As Integer
Winsock1.GetData MyData
FirF = Left$(MyData, 4)
If FirF = "~on~" Then
MyLenF = Val(Mid$(MyData, 6, 1))
MyLenS = Val(Mid$(MyData, 7, MyLenF))
MsgBox MyLenF & MyLenS
ToName = Mid$(MyData, 7 + MyLenF, MyLenS)
MyLenF1 = Val(Mid$(MyData, 7 + MyLenF + MyLenS + 1, 1))
MyLenS1 = Val(Mid$(MyData, 7 + MyLenF + MyLenS + 1 + 1, MyLenF1))
ToInfo = Right(MyData, MyLenS1)
Open App.Path & "\" & "mychat.htm" For Append As #1
Print #1, "</font color=blue>" & ToName & "只对你说：</font>" & ToInfo & "</font>"
Close #1
WebBrowser1.Refresh
X = SendMessage(WebBrowser1.hwnd, WM_HSCROLL, SB_RIGHT, ByVal 0&)
End If
If FirF = "~ev~" Then
MyLenF = Val(Mid$(MyData, 6, 1))
MyLenS = Val(Mid$(MyData, 7, MyLenF))
MsgBox MyLenF & MyLenS
ToName = Mid$(MyData, 7 + MyLenF, MyLenS)
MyLenF1 = Val(Mid$(MyData, 7 + MyLenF + MyLenS + 1, 1))
MyLenS1 = Val(Mid$(MyData, 7 + MyLenF + MyLenS + 1 + 1, MyLenF1))
ToInfo = Right(MyData, MyLenS1)
Open App.Path & "\" & "mychat.htm" For Append As #1
Print #1, "</font color=blue>" & ToName & "对大家说" & Text2 & "说：</font>" & ToInfo & "</font>"
Close #1
WebBrowser1.Refresh
X = SendMessage(WebBrowser1.hwnd, WM_HSCROLL, SB_RIGHT, ByVal 0&)
End If
If FirF = "~nb~" Then
MyLenF = Val(Mid$(mygetdata, 6, 1))
MyLenS = Val(Mid$(MyData, 7, MyLenF))
ToName = Right$(mygetdata, MyLenS)
List1.AddItem ToName, UserIndex
UserIndex = UserIndex + 1
End If
If FirF = "~aq~" Then
MsgBox "已经退出聊天室！", vbOKOnly, "已经退出"
End If
If FirF = "~si~" Then
MyLenF = Val(Mid$(mygetdata, 6, 1))
MyLenS = Val(Mid$(MyData, 7, MyLenF))
ToName = Right$(mygetdata, MyLenS)
MsgBox ToName, vbOKOnly, "服务器消息"
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -