frmmain.frm

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

Dim txtpost As String
Dim strCookie As String
strUrl = "http://passport.baidu.com/?business"
txtpost = "aid=6&un=" & UTF(tmpFri)
strCookie = "Cookie: " & tmpCookie
Call frmMain.MyPost(strUrl, txtpost, strCookie, "userinfo")
End Sub
Public Sub UserInfoRead(tmptext As String)
Dim tmpHtml As String
Dim tmpStr As String
Dim i As Long
Dim ii As Long
If tmptext = "" Then Exit Sub
If InStr(tmptext, "<TITLE>用户不存在</TITLE>") > 0 Then Exit Sub
i = InStr(tmptext, "<div id=" & """" & "tabarea1" & """")
ii = InStr(tmptext, "<div id=" & """" & "tabarea2" & """")
tmpHtml = Mid(tmptext, i, ii - i)
'frmtmp.Text4.Text = tmpHtml
Do
i = InStr(tmpHtml, "<a")
If i > 0 Then
tmpStr = Right(tmpHtml, Len(tmpHtml) - i + 1)
ii = InStr(tmpStr, ">")
If ii = 0 Then GoTo exitdo
tmpStr = Left(tmpStr, ii)
tmpHtml = Replace(tmpHtml, tmpStr, "")
Else
GoTo exitdo
End If
Loop
exitdo:
tmpHtml = Replace(tmpHtml, "发送消息</a>", "")
tmpHtml = Replace(tmpHtml, "加为好友</a>", "")
tmpHtml = Replace(tmpHtml, "        给他留言", "")
tmpHtml = Replace(tmpHtml, "</a>", "")
If frmUserInfo.Caption <> "" Then Unload frmUserInfo '窗口是否加载
Load frmUserInfo
frmUserInfo.Visible = True
frmUserInfo.InfoWeb.Navigate "about:blank"
frmUserInfo.InfoWeb.Document.write tmpHtml
frmUserInfo.InfoWeb.Refresh
End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub cmdChatLogin_Click()
Call GroupLogin
End Sub




'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub cmdlogin_Click()
If UserName.Text = "" Or UserKey.Text = "" Then
MsgBox "用户名或密码不能为空！", , "Hello,Baidu."
Exit Sub
End If
cmdLogin.Enabled = False
cmdK_send.Enabled = False
LoginERR = False
'MyPostStar = True
If Inethttp(0).StillExecuting = False Then Call Login(UserName.Text, UserKey.Text)
End Sub

Private Sub cmdK_send_Click()
cmdK_send.Enabled = False
Call SendMsg(K_SendTo, K_SendMsg, "Ksendmsg")
End Sub

Public Sub Login(UName As String, PW As String)
Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
strUrl = "http://passport.baidu.com/?login"
txtpost = "tpl=sp&tpl_ok=&skip_ok=&aid=0&need_pay=&need_coin=0&pay_method=0&u=&next_target=&return_method=&more_param=&return_type=&username=" & UName & "&password=" & PW & "&Submit=+%B5%C7%C2%BC+"
strCookie = ""
tmpCookie = ""
'If LoginNow = True Then Call MyPost(strUrl, txtpost, strCookie, "login")
Call MyPost(strUrl, txtpost, strCookie, "login")
End Sub

Private Sub Command7_Click()

End Sub



Private Sub Command1_Click()
frmTmp.Visible = True
End Sub

Private Sub Form_Load()
Combo1.AddItem "Q"
Combo1.AddItem "B"
Combo1.AddItem "A"
Combo1.AddItem "I"
Combo1.AddItem "D"
Combo1.AddItem "U"
Combo1.AddItem "M"
'On Error Resume Next
musicKey = 3
soundKey = 0
menuKey = 2
Dim dayend As Date
dayend = #6/1/2007#
If Now - dayend > 0 Then MsgBox "程序已过期，请与作者联系！" & vbCrLf & "百度帐号：stcell", , "Hello,Baidu.": End
Height = 7710
Width = 3810
'InetPostNO = 0
cmdK_send.Enabled = False
Labelinfo.Caption = "作者：a.zhong" & vbCrLf & "[e-mail]"
menuMsg.Visible = False
menuFri.Visible = False
menuBad.Visible = False
menuChat.Visible = False
menuPOP.Visible = False

If FileExists(App.Path & "\xpbaidu.ico") = False Then
Dim Pic() As Byte
Pic = LoadResData(101, "CUSTOM")
Open App.Path & "\xpbaidu.ico" For Binary As #1
Put #1, , Pic
Close #1
End If
'////////////////////////////////////////////////////////


    '载入系统托盘
    TrayAddIcon frmMain, App.Path & "\xpbaidu.ico", "百度IM，我做主。"
    
    frmMain.WindowState = 0
    frmMain.Show
'///////////////////////////////////////////////////////

    Dim i As Long
    NextInet = 1
    For i = 1 To 20
        Load Inethttp(i)
    Next
ReDim MsgListDel(0)
ReDim MsgListRead(0)
ReDim MsgListTime(0)
ReDim MsgListUser(0)
ReDim MsgListId(0)
ReDim MsgListTxt(0)
ReDim MsgListRid(0)

ReDim GroupMsg(0)
ReDim GroupRoom(0)

ReDim InetListUrl(0)
ReDim InetListPost(0)
ReDim InetListHead(0)
ReDim InetListCmd(0)
ReDim InetListTxt(0)

ReDim Ftalk(0) As New frmTalk
ReDim Fgroup(0) As New frmGroup

MyPostStar = True

frmUserInfo.InfoWeb.Navigate "about:blank"

LoginERR = False

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    '气泡单击时的鼠标事件
    Dim Result As Long
    Dim cEvent As Single
    cEvent = X / Screen.TwipsPerPixelX

    Select Case cEvent

    Case MouseMove
        'Debug.Print "MouseMove"
    Case LeftUp
        Debug.Print "左键放开"
    Case LeftDown
        Debug.Print "左键按下"
        frmMain.WindowState = 0
        frmMain.Show
    Case LeftDbClick
        Debug.Print "左键双击"
    Case MiddleUp
        Debug.Print "中间键放开"
    Case MiddleDown
        Debug.Print "中间键按下"
    Case MiddleDbClick
        Debug.Print "中间键单击"
    Case RightUp
        Debug.Print "右健放开"
    Case RightDown
        Debug.Print "右健按下"
        '单击后移出
        Result = SetForegroundWindow(Me.hwnd)
        '当时显示
        Me.PopupMenu Me.menuPOP
    Case RightDbClick
        Debug.Print "右健双击"
    Case BalloonClick
        Debug.Print "单击气泡"
    frmMain.WindowState = 0
    frmMain.Show
    TrayTip frmMain, "百度IM，我做主。"
    SSTab1.Tab = 2
    End Select

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim ret As Long
'取消Message的截取，使之送往原来的window程序
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc)
Call UnregisterHotKey(Me.hwnd, uVirtKey1)
End Sub
Private Sub Form_Resize()
If Me.WindowState = vbMinimized Then
Me.Hide
TrayBalloon frmMain, "我在这里！<Alt>+" & Combo1.Text, "百度IM，我做主。", NIIF_INFO
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
 TrayRemoveIcon
OnLine = False
MyPostStar = False
Dim i As Long
On Error Resume Next
For i = 0 To UBound(Fgroup) - 1
Unload Fgroup(i)
Next
For i = 0 To UBound(Ftalk) - 1
Unload Ftalk(i)
Next
'For i = 0 To Inethttp.UBound - 1
'Unload Inethttp(i)
'Next
Unload frmUserInfo
Unload frmList
Unload frmInfo
Unload frmTmp
End
End Sub
Public Sub reSet()
LoginERR = True
        OnLine = False
        MyPostStar = False
        Logout = 0
        ReDim MsgListRead(0)
        ReDim MsgListTime(0)
        ReDim MsgListUser(0)
        ReDim MsgListId(0)
        ReDim MsgListTxt(0)
        ReDim MsgListDel(0)
        ReDim MsgListRid(0)
        

ReDim InetListTxt(Inethttp.Count) As String
ReDim InetListUrl(Inethttp.Count) As String
ReDim InetListPost(Inethttp.Count) As String
ReDim InetListHead(Inethttp.Count) As String
ReDim InetListCmd(Inethttp.Count) As String
        
        ListFri.Clear
        ListMsg.Clear
        ListBad.Clear
        ListChat.Clear
        
        ' UserKey.Text.Text = ""
         
        cmdK_send.Enabled = False
        cmdLogin.Enabled = True
        
       LableLogin.Caption = "登录失败" & vbCrLf & LableLogin.Caption
       frmMain.Caption = "Hello,Baidu."
       tmpCookie = ""
End Sub

Private Sub InetHttp_StateChanged(Index As Integer, ByVal State As Integer)
Dim Buff As String
Dim Content As String
Dim txtContent As String


Select Case State

    Case icError '与主机通讯时出现了错误。
        'Debug.Print "与主机通讯时出现了错误。" & Index

        Call MyPost(InetListUrl(Index), InetListPost(Index), InetListHead(Index), InetListCmd(Index))
        'MsgBox InetListCmd(Index) & "icError", , "Hello,Baidu."
        Label13.Caption = "Err:" & Index
        InetErrTime = InetErrTime + 1
        If InetErrTime = 10 Then
        InetErrTime = 0
        Call reSet
        MsgBox "请重新登录！", , "Hello,Baidu.": LoginERR = True
        End If
         LableLogin.Caption = "错误:与主机通讯时出现了错误。" & vbCrLf & "请检查网络或重试." & vbCrLf & LableLogin.Caption
        'MsgBox "错误:与主机通讯时出现了错误。" & vbCrLf & "请检查网络或重试.", , "Hello,Baidu."
    Case icResponseCompleted '该请求已经完成，并且所有数据均已接收到。

        'Debug.Print "该请求已经完成，并且所有数据均已接收到。" & Index
        Label13.Caption = Index
       Do
           Buff = Inethttp(Index).GetChunk(1024)
           Content = Content & Buff
        Loop While Len(Buff) > 0
        
        If InStr(InetListCmd(Index), "group") > 0 Or InStr(InetListCmd(Index), "room") > 0 Then frmTmp.Text4.Text = InetListTxt(Index)
        
        If InStr(Content, "var errNo = 10106") > 0 > 0 Or InStr(Content, "<title>用户登录</title>") > 0 And InStr(Content, "<strong>百度注册用户请直接登录</strong>") > 0 Or InStr(Content, "<title>百度个人中心_网友留言</title>") > 0 And InStr(Content, ">您目前处于未登录状态，请您<a href=") > 0 Then
        '<title>用户登录</title><strong>百度注册用户请直接登录</strong>
        '<title>百度个人中心_网友留言</title>==>您目前处于未登录状态，请您<a href=
        Logout = Logout + 1
        If Inethttp(0).StillExecuting = True Then Logout = 0: Exit Sub
        If Logout > 3 Then
        Call reSet
        MsgBox "登录失败!" & Index, , "Hello,Baidu."
      If InStr(Content, "验证码不匹配，请重新输入验证码") > 0 Then MsgBox "验证码不匹配,请重新运行程序。": End
        Exit Sub
        Else
        Call cmdlogin_Click
        End If
        Call MyPost(InetListUrl(Index), InetListPost(Index), InetListHead(Index), InetListCmd(Index))
        Exit Sub
        End If
        
         InetListTxt(Index) = Content
         
        txtContent = Content
       ' frmtmp.Text4.Text = txtContent
      
       If InetListCmd(Index) = "login" Then tmpCookie = Inethttp(Index).GetHeader("Set-Cookie")
       'tmpCookie = Inethttp(Index).GetHeader("Set-Cookie")
       
       Dim tmptxt As String
       Select Case InetListCmd(Index)
       Case "login"

       If InStr(txtContent, "用户登录") > 0 And InStr(txtContent, "忘记密码") > 0 Then
        Call reSet
       Else
       LableLogin.Caption = "登录成功" & vbCrLf & LableLogin.Caption
       LoginERR = False
       frmMain.Caption = "Hello,Baidu. " & UserName.Text
       Logout = 0
       OnLine = True
       cmdK_send.Enabled = True
       Call Getmsg0
       Call Getmsg1
       Call Getmsg2
       Call GetFri
       Call GetBad
       End If
       cmdLogin.Enabled = True
       
       Case "logout"
       Case "Ksendmsg"
       tmptxt = "var cmdNo = " + """" + "no1" + """" '发送
       If InStr(txtContent, tmptxt) > 0 Then
       LableLogin.Caption = "发送成功" & vbCrLf & LableLogin.Caption
       Else
       LableLogin.Caption = "发送失败" & vbCrLf & LableLogin.Caption
       End If
       cmdK_send.Enabled = True
       Case "getfri"
       Call readfrilist(InetListTxt(Index))
       Case "getbad"
       Call readBadlist(InetListTxt(Index))
       Case "getmsg0"
       Call readmsglist(InetListTxt(Index), 0)
       Case "getmsg1"
       Call readmsglist(InetListTxt(Index), 1)
       Case "getmsg2"
       Call readmsglist(InetListTxt(Index), 2)
       Case "readmsg"
    '   MsgBox "readmsg"
       Dim iid As String
       Dim i As Long
       iid = Right(InetListPost(Index), Len(InetListPost(Index)) - InStrRev(InetListPost(Index), "="))
       For i = 0 To UBound(MsgListTxt) - 1
       If Val(iid) = MsgListId(i) Then
       MsgListRead(i) = True
       If InetListTxt(Index) = "theMessageHaveBeenDeled" Then MsgListDel(i) = True
       MsgListTxt(i) = readmsg(InetListTxt(Index))
       Exit Sub
       End If
       Next
       'MsgListTxt(InetListTmp(Index)) = readmsg(InetListTxt(Index))
       Case "findfri"
            Call FriListRead(InetListTxt(Index))