📄 frmrtchat.frm
字号:
VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "richtx32.ocx"
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmRTChat
BorderStyle = 1 'Fixed Single
Caption = "聊天"
ClientHeight = 4860
ClientLeft = 45
ClientTop = 330
ClientWidth = 5715
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4860
ScaleWidth = 5715
StartUpPosition = 3 '窗口缺省
Begin VB.OptionButton Option2
Caption = "打开语音"
Height = 255
Left = 2640
TabIndex = 5
Top = 0
Width = 1215
End
Begin VB.OptionButton Option1
Caption = "关闭语音"
Height = 255
Left = 1560
TabIndex = 4
Top = 0
Width = 1215
End
Begin RichTextLib.RichTextBox RTFOut
Height = 1935
Left = 120
TabIndex = 1
Top = 2520
Width = 5415
_ExtentX = 9551
_ExtentY = 3413
_Version = 393217
BackColor = 0
Enabled = -1 'True
ScrollBars = 2
TextRTF = $"frmRTChat.frx":0000
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Times New Roman"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin RichTextLib.RichTextBox RTFIn
Height = 1935
Left = 120
TabIndex = 0
Top = 360
Width = 5415
_ExtentX = 9551
_ExtentY = 3413
_Version = 393217
BackColor = 0
Enabled = -1 'True
ReadOnly = -1 'True
ScrollBars = 2
TextRTF = $"frmRTChat.frx":007C
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Times New Roman"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin MSWinsockLib.Winsock Winsock1
Left = 5280
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.Label lblStatus
Height = 255
Left = 120
TabIndex = 6
Top = 4560
Width = 5295
End
Begin VB.Label Label2
Caption = "本地"
Height = 255
Left = 120
TabIndex = 3
Top = 2280
Width = 1215
End
Begin VB.Label Label1
Caption = "主机"
Height = 255
Left = 120
TabIndex = 2
Top = 120
Width = 1215
End
End
Attribute VB_Name = "frmRTChat"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'============
'语音聊天窗体
'=============
'语音处理函数
Private Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal _
hwndCallback As Long) As Long
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
'=============
'连接到服务器
'=============
Private Sub Connect()
On Error Resume Next
Winsock1.Close '关闭winsock
Winsock1.RemotePort = "1981"
Winsock1.Connect RTChatRemoteIP '尝试连接
lblStatus.Caption = "连接到 " + txtRemoteIP.Text '显示标题，正在连接
End Sub
'===============
'窗体卸载
'===============
Private Sub Form_Unload(cancel As Integer)
On Error Resume Next
Winsock1.Close
lblStatus.Caption = "连接失败 " '显示标题，正在失败
End Sub
'==========
'SOCKET监听
'==========
Private Sub Listen()
Winsock1.Close
Winsock1.LocalPort = "1981"
Winsock1.Listen '监听连接
DoEvents
RTChatTemp = Me.Caption
MyIM.Winsock1.SendData ".BeginRTChat " & RTChatTemp
lblStatus.Caption = "等待连接请求" '修改窗体标题
End Sub
'===============
'窗体启动过程
'===============
Private Sub Form_Load()
On Error Resume Next '错误处理语句
Option1.value = True '初使化，打开声音
RTFOut.SelColor = &H80FF80 '本地文本框字体颜色
Winsock1.Close '关闭SOCKET连接
RTFIn.SelColor = &HC0E0FF
lblStatus.Caption = "状态 - 等待信息"
If Option1.value = True Then
'如果选择打开声音，则播放声音文件xcstartup.wav
playsound = sndPlaySound("xcstartup.wav", 1)
End If
'If RTCListen = True Then
' Listen
'Else
' Connect
'End If
End Sub
Private Sub RTFIn_Change()
RTFIn.SelStart = Len(RTFIn.Text)
End Sub
'==============
'输入字符过程
'==============
Private Sub RTFOut_KeyPress(KeyAscii As Integer)
On Error GoTo ErrRTFOKP '错误处理事件，出错则转到ErrRTFOKP
Dim playsound As Long
'如果打开声音选项为开的话，则播放声音xctype.wav
If Option1.value = True Then
playsound = sndPlaySound("xctype.wav", 1)
End If
'改变本地文本字颜色
RTFOut.SelStart = Len(RTFOut.Text)
RTFOut.SelColor = &H80FF80
'发送输入的每个字符
Winsock1.SendData Chr(KeyAscii)
Exit Sub
ErrRTFOKP:
lblStatus.Caption = Err.Description '在状态栏显示错误信息
Resume Next
End Sub
'===================
'SOCKET关闭过程
'===================
Private Sub Winsock1_Close()
Dim playsound As Long '
If Option1.value = True Then
playsound = sndPlaySound("xcdiscon.wav", 1)
End If
lblStatus.Caption = "连接已关闭" '通知用户连接已关闭
End Sub
'===================
'SOCKET连接过程
'===================
Private Sub Winsock1_Connect()
On Error Resume Next
lblStatus.Caption = "连接成功"
RTFOut.SetFocus '将光标移到输出文本窗口
End Sub
'================
'发送连接请求事件
'================
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
On Error Resume Next '错误处理
'如果SOCKET已经打开，则关闭它
If Winsock1.State <> sckClosed Then Winsock1.Close
'接收连接请求
Winsock1.Accept requestID
lblStatus.Caption = "连接消息已发送"
'播放发送连接声音
If Option1.value = True Then
playsound = sndPlaySound("xcestab.wav", 1)
End If
'将光标移到输出文本窗口
RTFOut.SetFocus
End Sub
'=============
'SOCKET数据接收事件
'=============
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim currenttext As String
Dim ndata As String
Dim TempBegin As Integer
On Error Resume Next '错误处理， 如果出错则转到下一句
Winsock1.GetData ndata '接收数据，放到ndata变量中
If InStr(1, ndata, Chr(8)) Then
TempBegin = 0
Do While InStr(TempBegin + 1, ndata, Chr(8)) > 0
If Len(RTFIn.Text) = 0 Then Exit Sub
TempBegin = InStr(TempBegin + 1, ndata, Chr(8))
If Len(RTFIn.Text) = 1 Then RTFIn.Text = ""
If InStr(Len(RTFIn.Text) - 1, RTFIn.Text, Chr(13)) Then
RTFIn.Text = Mid(RTFIn.Text, 1, Len(RTFIn.Text) - 2)
Else
RTFIn.Text = Mid(RTFIn.Text, 1, Len(RTFIn.Text) - 1)
End If
Loop
Exit Sub
End If
If InStr(1, ndata, Chr(13)) Then
ndata = Replace(ndata, Chr(13), vbCrLf & "\par ")
ndata = "{\rtf1\ansi\ansicpg1252\deff0\deftab720{\fonttbl{\f0\fswiss MS Sans Serif;}{\f1\froman\fcharset2 Symbol;}{\f2\froman Times New Roman;}}" & vbCrLf & "{\colortbl\red127\green127\blue127;}" & vbCrLf & "\deflang1033\pard\plain\f2\fs20\cf0 " & ndata
ndata = ndata & vbCrLf & "\plain\f2\fs20\par }"
RTFIn.SelRTF = ndata
Exit Sub
End If
RTFIn.SelStart = Len(RTFIn.Text)
RTFIn.SelColor = &HC0E0FF
RTFIn.SelText = ndata
End Sub
'=============
'SOCKET错误处理过程
'=============
Private Sub Winsock1_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)
lblStatus.Caption = Description '在状态栏显示错误信息
RTFOut.SetFocus
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -