frmmain.frm

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

       Case "userinfo"
             Call cmdlogin_Click
              Call UserInfoRead(InetListTxt(Index))
        Case "badadd"
               Call GetBad
        Case "baddel"
                 Call GetBad
        Case "friadd"
                 Call GetFri
        Case "fridel"
                 Call GetFri
        Case "tmpost"
           frmTmp.Text4.Text = InetListTxt(Index)
        Case "grouplogin"
        Call DoLoginG(InetListTxt(Index))
        Case "roomlogin"
        Call DoLoginR(InetListTxt(Index))
        Case "roomlogout"
        Call DoLogoutR(InetListTxt(Index))
        Case "roommsgsend"
        Call DoMsgSendG(InetListTxt(Index))
        Case "roommsgget"
        Call DoMsgGetG(InetListTxt(Index))
        Case "roomuserlock"
        Call DoUserLockG
        Case "roomuserlist"
        Call DoUserListG(InetListTxt(Index))
       End Select
    cmdK_send.Enabled = True
End Select
End Sub

Private Sub ListBad_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If ListBad.Text = "" Then
menuBadInfo.Enabled = False
menuBadDel.Enabled = False
menuBadtoFri.Enabled = False
Else
menuBadInfo.Enabled = True
menuBadDel.Enabled = True
menuBadtoFri.Enabled = True
End If
If Button = menuKey Then
Me.PopupMenu menuBad
End If
End Sub

Private Sub ListChat_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'If ListChat.Text = "" Then Exit Sub
If Button = menuKey Then
Me.PopupMenu menuChat
End If
End Sub

Private Sub ListFri_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If ListFri.Text = "" Then
menuFriMsg.Enabled = False
menuFriInfo.Enabled = False
menuFriDel.Enabled = False
menuFriBad.Enabled = False
Else
menuFriMsg.Enabled = True
menuFriInfo.Enabled = True
menuFriDel.Enabled = True
menuFriBad.Enabled = True
End If
If Button = menuKey Then
Me.PopupMenu menuFri
End If
End Sub

Private Sub ListMsg_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If ListMsg.Text = "" Then Exit Sub
If Button = menuKey Then
Me.PopupMenu menuMsg
End If
End Sub

Private Sub menuBadDel_Click()
If ListBad.Text = "" Then MsgBox "没有选中用户", , "Hello,Baidu.": Exit Sub
Call BadDel(ListBad.Text)
End Sub

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

Private Sub menuBadRefresh_Click()
Call GetBad
End Sub

Private Sub menuBadtoFri_Click()
If ListBad.Text = "" Then MsgBox "没有选中用户", , "Hello,Baidu.": Exit Sub
Call FriAdd(ListBad.Text)
End Sub

Private Sub menuChatEnter_Click()
If ListChat.Text = "" Then MsgBox "没有选中房间", , "Hello,Baidu.": Exit Sub
Dim tmproom As String
Dim i As Long
Dim tmpform As String
tmproom = ListChat.Text
If Left(tmproom, 1) = "_" Then MsgBox "请登先登记！", , "Hello,Baidu.": Exit Sub
tmproom = Replace(tmproom, "@ ", "")
'
For i = 0 To UBound(Ftalk)
If Fgroup(i).Caption = "" Then GoTo exit2
tmpform = Left(Fgroup(i).Caption, InStr(Fgroup(i).Caption, " ") - 1)
If tmproom = tmpform Then
Fgroup(i).WindowState = 0
Fgroup(i).SetFocus
GoTo exit1
End If
exit2:
Next
For i = 0 To UBound(Fgroup)
If Fgroup(i).Visible = False Then
Fgroup(i).Visible = True
Fgroup(i).Caption = tmproom & " 群：" & UserName.Text
GoTo exit1
End If
Next
ReDim Preserve Fgroup(UBound(Fgroup) + 1) As New frmGroup
Fgroup(UBound(Fgroup)).Visible = True
Fgroup(UBound(Fgroup)).Caption = tmproom & " 群：" & UserName.Text
exit1:
'
End Sub

Private Sub menuChatLogin_Click()
If ListChat.Text = "" Then MsgBox "没有选中房间", , "Hello,Baidu.": Exit Sub
Dim tmproom As String
tmproom = ListChat.Text
tmproom = Replace(tmproom, "@ ", "")
tmproom = Replace(tmproom, "_ ", "")
Call RoomLogin(tmproom, UserName.Text, UserKey.Text)
End Sub

Private Sub menuChatLogout_Click()
If ListChat.Text = "" Then MsgBox "没有选中房间", , "Hello,Baidu.": Exit Sub
Dim tmproom As String
tmproom = ListChat.Text
tmproom = Replace(tmproom, "_ ", "")
tmproom = Replace(tmproom, "@ ", "")
Call RoomLogout(tmproom, UserName.Text, UserKey.Text)
End Sub

Private Sub menuFriAdd_Click()
frmList.Visible = True
End Sub

Private Sub menuFriBad_Click()
If ListFri.Text = "" Then MsgBox "没有选中用户", , "Hello,Baidu.": Exit Sub
Dim tmpFri As String
tmpFri = Replace(ListFri.Text, "@ ", "")
tmpFri = Replace(tmpFri, "_ ", "")
Call BadAdd(tmpFri)
End Sub

Private Sub menuFriDel_Click()
If ListFri.Text = "" Then MsgBox "没有选中用户", , "Hello,Baidu.": Exit Sub
Dim tmpFri As String
tmpFri = Replace(ListFri.Text, "@ ", "")
tmpFri = Replace(tmpFri, "_ ", "")
Call FriDel(tmpFri)
End Sub

Private Sub menuFriFresh_Click() '刷新好友列表
Call GetFri
End Sub

Private Sub menuFriInfo_Click()
Dim tmpuser As String
If ListFri.Text = "" Then MsgBox "没有选中用户", , "Hello,Baidu.": Exit Sub
tmpuser = Replace(ListFri.Text, "@ ", "")
tmpuser = Replace(tmpuser, "_ ", "")
Call UserInfo(tmpuser)
End Sub

Private Sub menuFriMsg_Click() '交谈时：增加新窗口
If ListFri.Text = "" Then MsgBox "没有选中用户", , "Hello,Baidu.": Exit Sub
Dim i As Long
Dim tmpuser As String
Dim tmpform As String
tmpuser = Replace(ListFri.Text, "@ ", "")
tmpuser = Replace(tmpuser, "_ ", "")
For i = 0 To UBound(Ftalk)
If Ftalk(i).Caption = "" Then GoTo exit2
tmpform = Left(Ftalk(i).Caption, InStr(Ftalk(i).Caption, " ") - 1)
If tmpuser = tmpform Then
Ftalk(i).WindowState = 0
Ftalk(i).SetFocus
GoTo exit1
End If
exit2:
Next
For i = 0 To UBound(Ftalk)
If Ftalk(i).Visible = False Then
Ftalk(i).Visible = True
Ftalk(i).Caption = tmpuser & " 交谈中："
GoTo exit1
End If
Next
ReDim Preserve Ftalk(UBound(Ftalk) + 1) As New frmTalk
Ftalk(UBound(Ftalk)).Visible = True
Ftalk(UBound(Ftalk)).Caption = tmpuser & " 交谈中："
exit1:
For i = 0 To ListMsg.ListCount - 1
If ListMsg.List(i) = "" Then GoTo next3:
If tmpuser = Left(ListMsg.List(i), InStr(ListMsg.List(i), " ") - 1) Then ListMsg.RemoveItem (i)
next3:
Next
ListMsg.AddItem tmpuser & " 有0条新信息"
End Sub

Private Sub menuMsgAdd_Click()
If ListMsg.Text = "" Then MsgBox "没有选中用户", , "Hello,Baidu.": Exit Sub
Dim tmpFri As String
tmpFri = Left(ListMsg.Text, InStr(ListMsg.Text, " ") - 1)
Call FriAdd(tmpFri)
End Sub

Private Sub menuMsgBad_Click()
If ListMsg.Text = "" Then MsgBox "没有选中用户", , "Hello,Baidu.": Exit Sub
Dim tmpFri As String
tmpFri = Left(ListMsg.Text, InStr(ListMsg.Text, " ") - 1)
Call BadAdd(tmpFri)
End Sub

Private Sub menuMsgInfo_Click()
If ListMsg.Text = "" Then MsgBox "没有选中用户", , "Hello,Baidu.": Exit Sub
Call UserInfo(Left(ListMsg.Text, InStr(ListMsg.Text, " ") - 1))
End Sub

Private Sub menuMsgRefresh_Click()
Call Getmsg0
Call Getmsg1
Call Getmsg2
End Sub

Private Sub menuMsgTalk_Click() '交谈时：增加新窗口
Dim i As Long
Dim tmpuser As String
Dim tmpform As String
tmpuser = Left(ListMsg.Text, InStr(ListMsg.Text, " ") - 1)
For i = 0 To UBound(Ftalk)
If Ftalk(i).Caption = "" Then GoTo exit2
tmpform = Left(Ftalk(i).Caption, InStr(Ftalk(i).Caption, " ") - 1)
If tmpuser = tmpform Then
Ftalk(i).WindowState = 0
Ftalk(i).SetFocus
GoTo exit1
End If
exit2:
Next
For i = 0 To UBound(Ftalk)
If Ftalk(i).Visible = False Then
Ftalk(i).Visible = True
Ftalk(i).Caption = tmpuser & " 交谈中："
GoTo exit1
End If
Next
ReDim Preserve Ftalk(UBound(Ftalk) + 1) As New frmTalk
Ftalk(UBound(Ftalk)).Visible = True
Ftalk(UBound(Ftalk)).Caption = tmpuser & " 交谈中："
exit1:
For i = 0 To ListMsg.ListCount - 1
If ListMsg.List(i) = "" Then GoTo next3:
If tmpuser = Left(ListMsg.List(i), InStr(ListMsg.List(i), " ") - 1) Then ListMsg.RemoveItem (i)
next3:
Next
ListMsg.AddItem tmpuser & " 有0条新信息"
End Sub

Private Sub cmdListBadFresh_Click()
Call GetBad
End Sub

Private Sub cmdListFriFresh_Click()
Call GetFri
End Sub

Private Sub cmdListMsgFresh_Click()
Call Getmsg0
Call Getmsg1
Call Getmsg2
End Sub

Private Sub menuPOPexit_Click()
Unload Me
End Sub

Private Sub menuPOPhelp_Click()
Dim tmphelptxt As String
tmphelptxt = "如何手动安装百度IM彩信表情版？" & vbCrLf & vbCrLf & "如果你的QQ安装在" & vbCrLf & "C:\Program Files\Tencent\QQ" & vbCrLf & "你就把 百度IM彩信表情版 （本程序） " & vbCrLf & "复制到这个目录中." & vbCrLf & "并发送 快捷方式 到 桌面" & vbCrLf & "以便下次运行!"
MsgBox tmphelptxt, , "Hello,BaiDu. HELP.TXT"
End Sub

Private Sub menuPOPshow_Click()
    frmMain.WindowState = 0
    frmMain.Show
    TrayTip frmMain, "百度IM，我做主。"
    SSTab1.Tab = 1
End Sub



Private Sub Text1_Change()
Text1.Text = "http://hi.baidu.com/stcell"
End Sub

Private Sub Timer1_Timer()
If OnLine = True And MyPostStar = True Then
      Call Getmsg0
End If

End Sub

Private Sub Timer2_Timer()
If OnLine = True And MyPostStar = True Then
'Call GetFri
'Call GetBad
 Call Getmsg1
End If
If cmdLogin.Enabled = False Then cmdLogin.Enabled = True
End Sub

Public Sub BeBe(i As Variant)
On Error GoTo err0
Dim tmperr As Long
Dim bArr() As Byte
err0:
tmperr = tmperr + 1
If tmperr = 3 Then Exit Sub
If i = 0 Then
bArr = LoadResData("enter", "WAVE")
sndPlaySoundFromMemory bArr(0), SND_ASYNC Or SND_MEMORY
ElseIf i = 1 Then
bArr = LoadResData("tm", "WAVE")
sndPlaySoundFromMemory bArr(0), SND_ASYNC Or SND_MEMORY
ElseIf i = 2 Then
bArr = LoadResData("message", "WAVE")
sndPlaySoundFromMemory bArr(0), SND_ASYNC Or SND_MEMORY
Else
End If
End Sub

Public Sub POPO(i As Long)
If i = 0 Then
'显示无声气泡提示
    TrayBalloon frmMain, "你有新消息，点击图标查收!", "百度IM，我做主。", NIIF_INFO Or NIIF_NOSOUND
ElseIf i = 1 Then
    '显示气泡提示用法
    TrayBalloon frmMain, "你有新消息，点击图标查收!", "百度IM，我做主。", NIIF_INFO
Else
    '改变提示文字信息
    TrayTip frmMain, "百度IM，我做主。"
End If
End Sub

Function FileExists(ByVal File As String) As Boolean 'True表示文件存在
         On Error Resume Next
         Dim sfp As Integer
         sfp = GetAttr(File)
         If Err = 53 Then Exit Function
         FileExists = True
End Function

Private Sub Timer3_Timer()
If OnLine = True And MyPostStar = True Then
      Call Getmsg2
End If
End Sub

Public Sub GroupLogin()
Dim strCookie As String 'cookie
Dim postdata As String
strCookie = "Cookie: " & tmpCookie
postdata = "ver=1&command=hello"
Call MyPost(ListChatUrl, postdata, strCookie, "grouplogin")
End Sub
Public Sub RoomLogin(tmproom As String, tmpuser As String, tmpkey As String)
Dim strCookie As String 'cookie
Dim postdata As String
strCookie = "Cookie: " & tmpCookie
postdata = "ver=1&command=login" & "&key=" & tmpkey & "&room=" & UTF(tmproom) & "&username=" & UTF(tmpuser)
Call MyPost(ListChatUrl, postdata, strCookie, "roomlogin")
End Sub
Public Sub RoomLogout(tmproom As String, tmpuser As String, tmpkey As String)
Dim strCookie As String 'cookie
Dim postdata As String
strCookie = "Cookie: " & tmpCookie
postdata = "ver=1&command=logout" & "&key=" & tmpkey & "&room=" & UTF(tmproom) & "&username=" & UTF(tmpuser)
Call MyPost(ListChatUrl, postdata, strCookie, "roomlogout")
End Sub
Public Sub RoomMsgSend(tmproom As String, tmpuser As String, tmpkey As String, tmpmsg As String)
Dim str