frmrtchat.frm

ICQ通讯程序 ICQ通讯程序 ICQ通讯程序

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         =   "Chat"
   ClientHeight    =   4860
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5715
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4860
   ScaleWidth      =   5715
   StartUpPosition =   3  'Windows Default
   Begin VB.OptionButton Option2 
      Caption         =   "Sound Off"
      Height          =   255
      Left            =   2640
      TabIndex        =   5
      Top             =   0
      Width           =   1215
   End
   Begin VB.OptionButton Option1 
      Caption         =   "Sound On"
      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":00F4
      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         =   "Local Text:"
      Height          =   255
      Left            =   120
      TabIndex        =   3
      Top             =   2280
      Width           =   1215
   End
   Begin VB.Label Label1 
      Caption         =   "Remote Text:"
      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
' Leave these settings alone to play sounds within a VB program
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 ' If there's an error, resume the next command.
    Winsock1.Close ' Close any open ports (just in case).
    Winsock1.RemotePort = "1981"
    Winsock1.Connect RTChatRemoteIP ' Try to connect to the computer IP address specified in the txtRemoteIP text box, on the port specified in the txtPort text box.
    lblStatus.Caption = "Connecting to " + txtRemoteIP.Text ' Inform the user we are trying to connect to the specified IP address.
End Sub

Private Sub Form_Unload(cancel As Integer)
    On Error Resume Next ' If there's an error, resume next command.
    Winsock1.Close ' We want to disconnect or stop listening for a connection request, so close the connected or listening port.
    lblStatus.Caption = "Disconnected - Not Listening For Request." ' Show the user we are disconnected, and that we are not listening for a connection request.
End Sub

Private Sub Listen()
    Winsock1.Close
    Winsock1.LocalPort = "1981" ' Set the local port to listen on by getting the value from the txtPort text box.
    Winsock1.Listen ' Listen for the connection request by the other computer.
    DoEvents
    RTChatTemp = Me.Caption
    MyIM.Winsock1.SendData ".BeginRTChat " & RTChatTemp
    lblStatus.Caption = "Listening For Connection Request" ' Inform the user that we are listening for a connection request.
End Sub

Private Sub Form_Load()
    On Error Resume Next ' Resume next command if there is an error.
    Option1.value = True ' Turns sounds on by default.
    RTFOut.SelColor = &H80FF80 ' Make sure our text is green on the outgoing message box.
    Winsock1.Close ' Make sure that Winsock1 (our connection port) is closed on startup - just to be sure.
    RTFIn.SelColor = &HC0E0FF
    lblStatus.Caption = "Status Bar - Watch Here For Important Information "
    If Option1.value = True Then
        playsound = sndPlaySound("xcstartup.wav", 1) ' If the "Play Sounds" box is selected, play the sound.
    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 ' If there is an error in this subroutine, go to "err" code at bottom.
        Dim playsound As Long ' Declare the variable to hold the sound to be played if "Play Sounds" box is selected.
    If Option1.value = True Then
        playsound = sndPlaySound("xctype.wav", 1) ' If the "Play Sounds" box is selected, play the sound.
    End If
    RTFOut.SelStart = Len(RTFOut.Text) ' Set cursor to end of outgoing message box. This keeps the last message on the screen.
    RTFOut.SelColor = &H80FF80 ' Make sure our text is green on the outgoing message box.
    Winsock1.SendData Chr(KeyAscii) ' Send each character (as it is typed to the other) computer.
    Exit Sub
ErrRTFOKP:
    lblStatus.Caption = Err.Description ' Show the error to the user on the status bar.
    Resume Next ' Resume with next command after showing the error.
End Sub

Private Sub Winsock1_Close()
    Dim playsound As Long ' Declare the variable to hold the sound to be played if "Play Sounds" box is selected.
    If Option1.value = True Then
        playsound = sndPlaySound("xcdiscon.wav", 1) ' If the "Play Sounds" box is selected, play the sound.
    End If
    lblStatus.Caption = "Connection Has Been Closed." ' Show the user that the connection is closed.
End Sub

Private Sub Winsock1_Connect()
    On Error Resume Next ' If there's an error, continue with next command.
    lblStatus.Caption = "Connection successful!"
    RTFOut.SetFocus ' Set the focus on the box to enter messages to send to the other computer.
End Sub

Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
    On Error Resume Next ' Just in case there's an error, continue with next command.
    If Winsock1.State <> sckClosed Then Winsock1.Close ' Close any open socket (just in case).
    Winsock1.Accept requestID ' Accept the other computer's connection request.
    lblStatus.Caption = "Connection Has Been Established!" ' Show the user we have accepted the connection request, and are connected.
    If Option1.value = True Then
        playsound = sndPlaySound("xcestab.wav", 1) ' If the "Play Sounds" is selected, play the default sound.
    End If
    RTFOut.SetFocus ' Set the focus on the box to enter messages to send to the other computer.
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim currenttext As String ' String to hold contents of RTFIn if needed.
    Dim ndata As String ' Declare a variable to hold the incoming data.
    Dim TempBegin As Integer
    On Error Resume Next ' If there's an error, resume next command.
    Winsock1.GetData ndata ' Get the incoming data and store it in variable "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) ' Set the cursor to the end of the text box to hold the incoming messages.
    RTFIn.SelColor = &HC0E0FF
    RTFIn.SelText = ndata
    RTFIn.SelStart = Len(RTFIn.Text) ' Set the cursor to the end of the text box.
End Sub

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 ' If there was a winsock error, show the user.
    RTFOut.SetFocus ' Set the focus back on the message box to send another message.
End Sub