frmtalk.frm

baidu_IM源程序,解压后就可以看到。自己还没有试过,不过貌似很不错的

RichTextBox(2).SelBold = False
End If
End Sub

Private Sub Cmd_I_Click()
If MyI = "" Then
MyI = "[#I]"
RichTextBox(2).SelStart = 0
RichTextBox(2).SelLength = Len(RichTextBox(2).Text)
RichTextBox(2).SelItalic = True
Else
MyI = ""
RichTextBox(2).SelStart = 0
RichTextBox(2).SelLength = Len(RichTextBox(2).Text)
RichTextBox(2).SelItalic = False
End If
End Sub

Private Sub cmd_PIC_Dn_Click()
MyFacePic = MyFacePic + 52
cmd_PIC_UP.Enabled = True
Call Picture1_Click
End Sub

Private Sub cmd_PIC_Up_Click()
MyFacePic = MyFacePic - 52
If MyFacePic <= 0 Then MyFacePic = 0: cmd_PIC_UP.Enabled = False: cmd_PIC_Dn.Enabled = True
Call Picture1_Click
End Sub

Private Sub Cmd_U_Click()
If MyU = "" Then
MyU = "[#U]"
RichTextBox(2).SelStart = 0
RichTextBox(2).SelLength = Len(RichTextBox(2).Text)
RichTextBox(2).SelUnderline = True
Else
MyU = ""
RichTextBox(2).SelStart = 0
RichTextBox(2).SelLength = Len(RichTextBox(2).Text)
RichTextBox(2).SelUnderline = False
End If
End Sub

Private Sub CmdClear_Click()
RichTextBox(0).Text = ""
End Sub

Private Sub CmdFace_Click()
Frame1.Visible = False
Dim savetime As Double
SendMsg.Text = SendMsg.Text & "[#END][#STAR]" & MyFace & "[#END][#STAR]"
SendMsg.Text = Replace(SendMsg.Text, "[#END][#STAR][#FACE=", "[#/")
SendMsg.Text = Replace(SendMsg.Text, "][#END][#STAR]", "/]")
End Sub

Private Sub cmdSendMsg_Click()
Dim tmpTalk As String
On Error GoTo exitsub2
If soundKey = 1 Then Call frmMain.BeBe(0)
If SendMsg.Text = "" Then MsgBox "内容不能为空", , "Hello,Baidu.": Exit Sub
If ToUser = "系统管理员" Then MsgBox "发信息不成功", , "Hello,Baidu.": Exit Sub
tmpTalk = "[#STAR]" & SendMsg.Text & "[#END]"
tmpTalk = Replace(tmpTalk, "[#/", "[#END][#STAR][#FACE=")
tmpTalk = Replace(tmpTalk, "/]", "][#END][#STAR]")
tmpTalk = Replace(tmpTalk, "[#STAR]", "[#STAR]" & MyFont & MySize & MyColor & MyI & MyU & MyB)
tmpTalk = Replace(tmpTalk, "[#STAR]" & MyFont & MySize & MyColor & MyI & MyU & MyB & "[#END]", "")
'Debug
Call frmMain.SendMsg(ToUser, tmpTalk, "sendmsg " & ToUser)
tmpTalk = "[#STAR]" & vbCrLf & Now & " 你说：" & vbCrLf & "[#END]" & tmpTalk
Call DoRichText(tmpTalk)
GoTo exitsub
exitsub2:
MsgBox "发信息不成功", , "Hello,Baidu."
exitsub:
SendMsg.Text = ""
SendMsg.SetFocus
End Sub

Private Sub Combo1_Click()
SendMsg.Text = Trim(Combo1.List(Combo1.ListIndex))
Call cmdSendMsg_Click
End Sub

Private Sub Combo2_Click()
RichTextBox(2).SelStart = 0
RichTextBox(2).SelLength = Len(RichTextBox(2).Text)
RichTextBox(2).SelFontSize = CInt(Combo2.List(Combo2.ListIndex))
MySize = "[#SIZE=" & Trim(Combo2.List(Combo2.ListIndex)) & "]"
'MsgBox MySize
End Sub

Private Sub Combo3_Click()
RichTextBox(2).SelStart = 0
RichTextBox(2).SelLength = Len(RichTextBox(2).Text)
RichTextBox(2).SelFontName = Combo3.List(Combo3.ListIndex)
MyFont = "[#FONT=" & Combo3.List(Combo3.ListIndex) & "]"
'MsgBox MyFont
End Sub

Private Sub Combo4_Change()

If frmMain.FileExists(App.Path & "\face\" & Trim(Combo4.Text) & ".gif") = True Then
Picture1.Picture = LoadPicture(App.Path & "\face\" & Trim(Combo4.Text) & ".gif")
MyFace = "[#FACE=" & Trim(Combo4.Text) & "]"
cmdFace.Enabled = True
Else
Picture1.Picture = LoadPicture("")
cmdFace.Enabled = False
MyFace = ""
End If
End Sub

Private Sub Combo4_Click()

If frmMain.FileExists(App.Path & "\face\" & Trim(Combo4.List(Combo4.ListIndex)) & ".gif") = True Then
Picture1.Picture = LoadPicture(App.Path & "\face\" & Trim(Combo4.List(Combo4.ListIndex)) & ".gif")
MyFace = "[#FACE=" & Trim(Combo4.List(Combo4.ListIndex)) & "]"
cmdFace.Enabled = True
Else
Picture1.Picture = LoadPicture("")
cmdFace.Enabled = False
MyFace = ""
End If
If cmd_PIC_Dn.Enabled = False And cmd_PIC_UP.Enabled = False And cmdFace.Enabled = False Then
MsgBox "请下载表情文件到FACE目录中!", , "Hello,Baidu."
cmd_PIC_Dn.Enabled = True
cmd_PIC_UP.Enabled = True
Frame1.Visible = False
End If
End Sub

Private Sub Command1_Click()

End Sub

Private Sub FacePic_Click(Index As Integer)
Picture1.Picture = FacePic(Index).Picture
Combo4.Text = Trim(Str(Index + MyFacePic))
End Sub

Private Sub Form_Activate()
Focus = True
End Sub

Private Sub Form_Deactivate()
Focus = False
End Sub

Private Sub Form_Load()
MyFacePic = 0
Frame1.Visible = False
cmd_PIC_UP.Enabled = False
Dim counter As Integer
For counter = 0 To Screen.FontCount - 1
Combo3.AddItem Screen.Fonts(counter)
Next
For counter = 8 To 22
Combo2.AddItem Str(counter)
Next
For counter = 0 To 95
Combo4.AddItem Str(counter)
Next
Combo1.AddItem "我正在用==>百度IM，我做主。"
Combo1.AddItem "噢"
Combo1.AddItem "好"
Combo1.AddItem "知道了"
Combo1.AddItem "拜拜"
'Debug

'Timer1.Interval = 0

Timer1.Interval = 1500
cmdFace.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
Timer1.Interval = 0
frmMain.Timer1.Interval = 7000
frmMain.Timer2.Interval = 8000
frmMain.Timer3.Interval = 9000
End Sub

Private Sub Picture1_Click()
On Error GoTo errtime
Frame1.Visible = True
Dim i As Long
For i = 0 To 51
If frmMain.FileExists(App.Path & "\face\" & Trim(Str(i + MyFacePic)) & ".gif") = True Then
FacePic(i).Picture = LoadPicture(App.Path & "\face\" & Trim(Str(i + MyFacePic)) & ".gif")
Else
FacePic(i).Picture = LoadPicture("")
cmd_PIC_Dn.Enabled = False
End If
Next
GoTo exitsub
errtime:
MkDir App.Path & "\face"
MsgBox "请下载表情文件到FACE目录中!", , "Hello,Baidu."
exitsub:
End Sub


Private Sub SendMsg_KeyPress(KeyAscii As Integer)
If KeyAscii = 10 Then
KeyAscii = 0
Call cmdSendMsg_Click
End If
End Sub

Private Sub Timer1_Timer()
On Error GoTo exitsub
Dim tmpTalk As String
If Me.Caption = "" Then Exit Sub
ToUser = Left(Me.Caption, InStr(Me.Caption, " ") - 1)

Dim i As Long
For i = 0 To UBound(MsgListUser) - 1
If ToUser = MsgListUser(i) And MsgListDel(i) = False Then
If Trim(MsgListRid(i)) = "0" Then frmMain.Timer1.Interval = 1000
If Trim(MsgListRid(i)) = "1" Then frmMain.Timer2.Interval = 1000
If Trim(MsgListRid(i)) = "2" Then frmMain.Timer3.Interval = 1000
Call frmMain.GetMsg(MsgListId(i))
MsgListRead(i) = True
End If
Next

For i = 0 To UBound(MsgListUser) - 1
If ToUser = MsgListUser(i) And MsgListTxt(i) <> "" And MsgListDel(i) = False Then
If InStr(MsgListTxt(i), "[#STAR]") > 0 And InStr(MsgListTxt(i), "[#END]") > 0 Then
tmpTalk = "[#STAR]" & vbCrLf & MsgListUser(i) & " " & MsgListTime(i) & vbCrLf & "[#END]" & MsgListTxt(i) & vbCrLf
Else
tmpTalk = "[#STAR]" & vbCrLf & MsgListUser(i) & " " & MsgListTime(i) & vbCrLf & MsgListTxt(i) & vbCrLf & "[#END]"
End If
Call DoRichText(tmpTalk)
'TalkRecord.Text = TalkRecord.Text & vbCrLf & MsgListUser(i) & " " & MsgListTime(i) & vbCrLf & MsgListTxt(i) & vbCrLf
If soundKey = 1 Then Call frmMain.BeBe(musicKey)

MsgListDel(i) = True
Call frmMain.DelMsg(MsgListId(i), MsgListRid(i))
End If
Next

If Focus = True Then
For i = 0 To frmMain.ListMsg.ListCount - 1
If frmMain.ListMsg.List(i) = "" Then GoTo exit1:
If ToUser = Left(frmMain.ListMsg.List(i), InStr(frmMain.ListMsg.List(i), " ") - 1) Then frmMain.ListMsg.RemoveItem (i)
Next
exit1:
frmMain.ListMsg.AddItem ToUser & " 有0条新信息"
End If
exitsub:
End Sub

Private Sub VScroll1_Change()
RichTextBox(2).SelStart = 0
RichTextBox(2).SelLength = Len(RichTextBox(2).Text)
RichTextBox(2).SelColor = RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value)
MyColor = "[#COLOR=" & VScroll1.Value & "," & VScroll2.Value & "," & VScroll3.Value & "]"
End Sub
Private Sub VScroll2_Change()
RichTextBox(2).SelStart = 0
RichTextBox(2).SelLength = Len(RichTextBox(2).Text)
RichTextBox(2).SelColor = RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value)
MyColor = "[#COLOR=" & VScroll1.Value & "," & VScroll2.Value & "," & VScroll3.Value & "]"
End Sub
Private Sub VScroll3_Change()
RichTextBox(2).SelStart = 0
RichTextBox(2).SelLength = Len(RichTextBox(2).Text)
RichTextBox(2).SelColor = RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value)
MyColor = "[#COLOR=" & VScroll1.Value & "," & VScroll2.Value & "," & VScroll3.Value & "]"
End Sub
Function Rich_Text(tmptext As String) As String
Dim tmptxt As String
Dim i As Integer
Dim ii As Integer
Dim txt As String
tmptxt = Replace(tmptext, "[#U]", "")
tmptxt = Replace(tmptxt, "[#B]", "")
tmptxt = Replace(tmptxt, "[#I]", "")
tmptxt = Replace(tmptxt, "[#STAR]", "")
tmptxt = Replace(tmptxt, "[#END]", "")

If InStr(tmptext, "[#SIZE=") > 0 Then
i = InStr(tmptext, "[#SIZE=")
For ii = i To Len(tmptext)
If Mid(tmptext, ii, 1) = "]" Then
txt = Mid(tmptext, i, ii - i + 1)
tmptxt = Replace(tmptxt, txt, "")
Exit For
End If
Next
End If
If InStr(tmptext, "[#FONT=") > 0 Then
i = InStr(tmptext, "[#FONT=")
For ii = i To Len(tmptext)
If Mid(tmptext, ii, 1) = "]" Then
txt = Mid(tmptext, i, ii - i + 1)
tmptxt = Replace(tmptxt, txt, "")
Exit For
End If
Next
End If
If InStr(tmptext, "[#COLOR=") > 0 Then
i = InStr(tmptext, "[#COLOR=")
For ii = i To Len(tmptext)
If Mid(tmptext, ii, 1) = "]" Then
txt = Mid(tmptext, i, ii - i + 1)
tmptxt = Replace(tmptxt, txt, "")
Exit For
End If
Next
End If

Rich_Text = tmptxt
End Function
Sub DoRich(tmptext As String)

Dim i As Integer
Dim ii As Integer
Dim txt As String

If InStr(tmptext, "[#U]") > 0 Then
RichTextBox(1).SelStart = 0
RichTextBox(1).SelLength = Len(RichTextBox(1).Text)
RichTextBox(1).SelUnderline = True
End If
If InStr(tmptext, "[#I]") > 0 Then
RichTextBox(1).SelStart = 0
RichTextBox(1).SelLength = Len(RichTextBox(1).Text)
RichTextBox(1).SelItalic = True
End If
If InStr(tmptext, "[#B]") > 0 Then
RichTextBox(1).SelStart = 0
RichTextBox(1).SelLength = Len(RichTextBox(1).Text)
RichTextBox(1).SelBold = True
End If
If InStr(tmptext, "[#SIZE=") > 0 Then
i = InStr(tmptext, "[#SIZE=")
For ii = i To Len(tmptext)
If Mid(tmptext, ii, 1) = "]" Then
txt = Mid(tmptext, i + 7, ii - i - 7)
RichTextBox(1).SelStart = 0
RichTextBox(1).SelLength = Len(RichTextBox(1).Text)
RichTextBox(1).SelFontSize = txt
Exit For
End If
Next
End If
If InStr(tmptext, "[#FONT=") > 0 Then
i = InStr(tmptext, "[#FONT=")
For ii = i To Len(tmptext)
If Mid(tmptext, ii, 1) = "]" Then
txt = Mid(tmptext, i + 7, ii - i - 7)
RichTextBox(1).SelStart = 0
RichTextBox(1).SelLength = Len(RichTextBox(1).Text)
RichTextBox(1).SelFontName = txt
Exit For
End If
Next
End If
If InStr(tmptext, "[#COLOR=") > 0 Then
i = InStr(tmptext, "[#COLOR=")
For ii = i To Len(tmptext)
If Mid(tmptext, ii, 1) = "]" Then
txt = Mid(tmptext, i + 8, ii - i - 8)
Dim r As Integer
Dim g As Integer
Dim b As Integer
i = InStr(txt, ",")
r = CInt(Left(txt, i - 1))
ii = InStrRev(txt, ",")
b = CInt(Mid(txt, ii + 1, Len(txt) - ii))
g = CInt(Mid(txt, i + 1, ii - i - 1))
RichTextBox(1).SelStart = 0
RichTextBox(1).SelLength = Len(RichTextBox(1).Text)
RichTextBox(1).SelColor = RGB(r, g, b)
Exit For
End If
Next
End If

If InStr(tmptext, "[#FACE=") > 0 Then
i = InStr(tmptext, "[#FACE=")
For ii = i To Len(tmptext)
If Mid(tmptext, ii, 1) = "]" Then
txt = Mid(tmptext, i + 7, ii - i - 7)
txt = Replace(txt, "[#FACE=", "")
txt = Replace(txt, "]", "")
If frmMain.FileExists(App.Path & "\face\" & Trim(txt) & ".gif") = False Then Exit For
RichTextBox(1).TextRTF = ""
Clipboard.Clear
Clipboard.SetData LoadPicture(App.Path & "\face\" & Trim(txt) & ".gif")
SendMessage RichTextBox(1).hwnd, 1088, 0, 0
Exit For
End If
Next
End If

End Sub

Private Sub DoRichText(tmptxt As String)
Dim i As Long

Dim tmpStr As String
Dim iStar As Long
Dim iEnd As Long

iStar = InStr(tmptxt, "[#STAR]")
If iStar = 0 Then
RichTextBox(0).SelStart = Len(RichTextBox(0).TextRTF) + 1
RichTextBox(0).SelLength = 0
RichTextBox(0).SelRTF = tmptxt
Exit Sub

ElseIf iStar <> 1 Then
tmpStr = Left(tmptxt, iStar - 1)
RichTextBox(0).SelStart = Len(RichTextBox(0).TextRTF) + 1
RichTextBox(0).SelLength = 0
RichTextBox(0).SelRTF = tmpStr
tmptxt = Replace(tmptxt, tmpStr, "")

End If

iStar = InStr(tmptxt, "[#STAR]")
iEnd = InStr(tmptxt, "[#END]")
Do While iStar > 0 And iEnd > 0
tmpStr = Mid(tmptxt, iStar, iEnd + 6 - iStar)
tmptxt = Replace(tmptxt, tmpStr, "")

RichTextBox(1).Text = ""
RichTextBox(1).Text = Rich_Text(tmpStr) '值
Call DoRich(tmpStr) '参数
RichTextBox(0).SelStart = Len(RichTextBox(0).TextRTF) + 1
RichTextBox(0).SelLength = 0
RichTextBox(1).SelStart = 0
RichTextBox(1).SelLength = Len(RichTextBox(1).TextRTF)
RichTextBox(0).SelRTF = RichTextBox(1).SelRTF '增加

iStar = InStr(tmptxt, "[#STAR]")
iEnd = InStr(tmptxt, "[#END]")

i = i + 1
If i > 100 Then Exit Do
Loop

End Sub