privatechat.frm

用Delphi写的网络聊天工具

End Sub

Private Sub cmdSend_Click()
On Error Resume Next
If Len(txtmessage.Text) < Len(nick & " >> ") + 1 Then
    Exit Sub
End If
'This is because the text in RichTextBox  is in RTF format and you can't write txtchat.Text = txtmessage.Text, as it will only copy the text from the source not the graphics.
'The RichTextBox format is originally in TextRTF format so whenever you are sending RichTextBox contents to other RichTextBox then always write
'RichTextBox1.TextRTF = RichTextBox2.TextRTF


'Disable Timer
Timer1.Enabled = False

'Set SelStart = 0 to copy the text from start
txtmessage.SelStart = 0
'Set lenght upto the length of txtmessage
txtmessage.SelLength = Len(txtmessage.Text)

'Set SelStart = length of txtchat
txtchat.SelStart = Len(txtchat.Text)
txtchat.SelUnderline = False

'copy the contents to txtchat
newstart = Len(txtchat.Text)
txtchat.SelStart = newstart

txtchat.SelFontName = FontNameIs
txtchat.SelItalic = IsItalic
txtchat.SelBold = IsBold
txtchat.SelText = txtmessage.Text & vbCrLf

'send data immediately to server
privateclient.SendData txtmessage.Text
DoEvents

'color the text in txtchat
COLORTEXT
'clear and set the start of typing in txtmessage
txtmessage.Text = ""
txtmessage.SelStart = Len(txtmessage.Text)

'restore factory defaults
txtmessage.SelColor = vbBlack
txtmessage.SelUnderline = False
End Sub

Private Sub Timer1_Timer()
NUDGE_ME
Timer1.Enabled = False
End Sub

Private Sub Timer4_Timer()
CONVERT_INTO_SMILEYS G_startfrom
End Sub

Private Sub txtchat_Change()
Timer4.Enabled = True
End Sub

Private Sub txtmessage_Change()
If Len(txtmessage.Text) < Len(nick & " >> ") Then
    txtmessage.Text = nick & " >> "
    txtmessage.SelStart = Len(txtmessage.Text)
    Exit Sub
End If
End Sub

Private Sub txtmessage_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    cmdSend_Click
End If
End Sub

Public Property Get nick() As String
nick = nickis
End Property

Public Property Let nick(ByVal newnick As String)
nickis = newnick
End Property

Private Sub WindowBorder_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 If Button = 1 Then
  ReleaseCapture
  SendMessage Me.hWnd, &HA1, 2, 0
  Exit Sub
 End If
End Sub


Private Sub hypercolor_Click()
cd.ShowColor
hypercolor.BackColor = cd.Color
hyper_color = hypercolor.BackColor
End Sub

Private Sub messagecolor_Click()
cd.ShowColor
messagecolor.BackColor = cd.Color
message_color = messagecolor.BackColor
End Sub

Private Sub namecolor_Click()
cd.ShowColor
namecolor.BackColor = cd.Color
name_color = namecolor.BackColor
End Sub

Private Sub backgroundcolor_Click()
cd.ShowColor
txtchat.BackColor = cd.Color
backgroundcolor.BackColor = cd.Color
End Sub

































Public Function COLORTEXT()

On Error Resume Next

Dim colorupto As Integer
Dim newstart2 As Integer

newstart2 = newstart

'color the whole message first
txtchat.SelStart = newstart
txtchat.SelLength = Len(txtchat.Text) - newstart
txtchat.SelColor = message_color

'color the name
colorupto = txtchat.Find(">>", newstart, Len(txtchat.Text))
If colorupto > -1 Then
    txtchat.SelStart = newstart
    txtchat.SelLength = colorupto - newstart + 2
    txtchat.SelColor = name_color

    'color the message
    newstart = colorupto + 2
    colorupto = Len(txtchat.Text)
    txtchat.SelStart = newstart
    txtchat.SelLength = colorupto - newstart
    txtchat.SelColor = message_color
    txtchat.SelStart = Len(txtchat.Text)
End If

'color the hyperlink
Dim colorstart, colorend As Integer

If txtchat.Find("http", newstart2, Len(txtchat.Text)) > -1 Then
    colorstart = txtchat.Find("http", newstart2, Len(txtchat.Text))
ElseIf txtchat.Find("www.", newstart2, Len(txtchat.Text)) > -1 Then
    colorstart = txtchat.Find("www.", newstart2, Len(txtchat.Text))
End If

If colorstart = 0 Then
    Exit Function
End If

newstart2 = colorstart
colorend = txtchat.Find(" ", newstart2, Len(txtchat.Text))
If colorstart > -1 Then
    txtchat.SelStart = colorstart
    If colorend = -1 Then
        txtchat.SelLength = Len(txtchat.Text) - colorstart
        txtchat.SelColor = hyper_color
        txtchat.SelUnderline = True
    Else
        txtchat.SelLength = colorend - colorstart
        txtchat.SelColor = hyper_color
        txtchat.SelUnderline = True
    End If
End If


End Function


Public Function CONVERT_INTO_SMILEYS(STARTFROM As Long)

Dim x_length As Long
Dim x_foundat As Long
Dim x_locset As Long
Dim x_EMOT As String
Dim x_i As Integer
Dim x_j As Integer

x_length = Len(txtchat.Text)

'run the loop upto the length of richtextbox
For x_i = STARTFROM To x_length
    x_foundat = txtchat.Find(":", x_i, x_length)
    x_locset = x_foundat
    
    If x_foundat = -1 Then
        x_i = x_length
        Timer4.Enabled = False
        Exit Function
    ElseIf x_foundat > -1 And IsNumeric(Mid(txtchat.Text, x_foundat + 2, 1)) = True Then
        x_foundat = x_foundat + 2
        'loop for calculating x_EMOT number
        For x_j = 1 To 4
            If IsNumeric(Mid(txtchat.Text, x_foundat, 1)) = True Then
                x_EMOT = x_EMOT & Mid(txtchat.Text, x_foundat, 1)
                x_foundat = x_foundat + 1
            Else
                Exit For
            End If
        Next
        'convert number into smiley
        If x_EMOT <> "" Then
            SET_PICTURE txtchat, x_locset, CInt(x_EMOT), Len(x_EMOT) + 1
            x_i = x_foundat - Len(x_EMOT) - 2
        Else
            x_i = x_foundat - 1
        End If
        
        x_EMOT = ""
    End If
    
    G_startfrom = x_length
    txtchat.SelStart = x_length
    Timer4.Enabled = False
Next

End Function


Public Function SET_PICTURE(rt_box As RichTextBox, pos As Long, EMOTICON As Integer, length As Integer)

'This function will paste the picture  in the Richtextbox at position = pos
'emoticon defines the picture number to be pasted
    On Error Resume Next
    Clipboard.Clear
    Clipboard.SetData LoadPicture(App.Path & "\emoticons\" & EMOTICON & ".gif"), vbCFBitmap
    rt_box.SelStart = pos
   'Replace the text   :) or :( or :| with empty string
    rt_box.SelLength = length
    rt_box.SelText = ""
    ' Paste the picture into the RichTextBox.
    SendMessage rt_box.hWnd, WM_PASTE, 0, 0
    
End Function



Public Function PLAY_SOUND(Filename As String)
sndPlaySound App.Path & "\" & Filename, SND_ASYNC Or SND_NODEFAULT
End Function

Public Sub NUDGE_ME()
Me.Top = Me.Top + 100
Me.Left = Me.Left + 200
Me.Top = Me.Top - 200
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left + 200
Me.Top = Me.Top - 200
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left + 200
Me.Top = Me.Top - 200
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left + 200
Me.Top = Me.Top - 200
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left + 200
Me.Top = Me.Top - 200
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left + 200
Me.Top = Me.Top - 200
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left + 200
Me.Top = Me.Top - 200
Me.Left = Me.Left - 100
Me.Top = Me.Top + 100
Me.Left = Me.Left - 100


End Sub

Public Property Get FontNameIs() As String
FontNameIs = x_fontname
End Property

Public Property Let FontNameIs(ByVal vNewValue As String)
x_fontname = vNewValue
End Property

Public Property Get IsItalic() As Boolean
IsItalic = x_IsItalic
End Property

Public Property Let IsItalic(ByVal vNewValue As Boolean)
x_IsItalic = vNewValue
End Property

Public Property Get IsBold() As Boolean
IsBold = x_IsBold
End Property

Public Property Let IsBold(ByVal vNewValue As Boolean)
x_IsBold = vNewValue
End Property