frmgroup.frm

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

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]", "")
tmpTalk = "[#STAR]" & frmMain.UserName.Text & " " & Now & "说:</br>[#END]" & tmpTalk
'Debug
Call frmMain.RoomMsgSend(ToUser, frmMain.UserName.Text, frmMain.UserKey.Text, 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 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()
menuPOP.Visible = False
MyFacePic = 0
Frame1.Visible = False
Frame2.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 = 1000
frmMain.Timer4.Interval = 1000
cmdFace.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
Timer1.Interval = 0
frmMain.Timer4.Interval = 0
End Sub

Private Sub List1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = menuKey Then
Me.PopupMenu menuPOP
End If
End Sub

Private Sub menuPOPinfo_Click()
If List1.Text = "" Then MsgBox "没有选中用户", , "Hello,Baidu.": Exit Sub
Call frmMain.UserInfo(Trim(List1.Text))
End Sub

Private Sub menuPOPlock_Click()
If List1.Text = "" Or ToUser = "" Then MsgBox "没有选中用户", , "Hello,Baidu.": Exit Sub
Call frmMain.RoomUserLock(ToUser, Trim(List1.Text), "1")
End Sub

Private Sub menuPOPrefresh_Click()
If ToUser = "" Then Exit Sub
Call frmMain.RoomUserList(ToUser)
End Sub

Private Sub menuPOPunlock_Click()
If List1.Text = "" Or ToUser = "" Then MsgBox "没有选中用户", , "Hello,Baidu.": Exit Sub
Call frmMain.RoomUserLock(ToUser, Trim(List1.Text), "0")
End Sub

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

Private Sub UserList(tmptext As String)
Dim i As Long
Dim tmpU As Variant
tmpU = Split(tmptext, ",")
List1.Clear
For i = LBound(tmpU) To UBound(tmpU)
List1.AddItem Trim(tmpU(i))
Next
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(GroupRoom) - 1
If ToUser = GroupRoom(i) Then
GroupRoom(i) = ""
If InStr(GroupMsg(i), "[#USERLIST]") = 1 Then
GroupMsg(i) = Replace(GroupMsg(i), "[#USERLIST]", "")
Call UserList(GroupMsg(i))
Exit Sub
End If
Call DoRichText(GroupMsg(i))
GroupMsg(i) = ""
If soundKey = 1 Then Call frmMain.BeBe(musicKey)
End If
Next
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

tmptxt = Replace(tmptxt, "</br>", vbCrLf)

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