frmmain.frm

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

    tmptxt = Mid(tmpMsgList, ti + 7, InStr(ti, tmpMsgList, ")") - ti - 7)
    tmptxt = Replace(tmptxt, "'", "")
    tmptiii = InStr(tmptxt, ",")
    tmptxt = Right(tmptxt, Len(tmptxt) - tmptiii) & ","
    tmpVar = Split(tmptxt, ",")
    tmpId = tmpVar(0)
    tmpuser = tmpVar(1)
    Vmsglist(tmpti) = Vmsglist(tmpti) & tmptxt
End If
'ListMsg.AddItem Vmsglist(tmpti)
Dim i As Long
Dim ii As Long
For i = 0 To UBound(MsgListId)
If tmpId = MsgListId(i) Then '排除重复信息

GoTo exit1
End If
Next

MsgListTime(UBound(MsgListTime)) = tmpTime
MsgListUser(UBound(MsgListUser)) = tmpuser
MsgListId(UBound(MsgListId)) = tmpId
MsgListRead(UBound(MsgListRead)) = False
MsgListDel(UBound(MsgListDel)) = False
MsgListRid(UBound(MsgListRid)) = tmpRid
'Call frmMain.GetMsg(tmpId, i)
'ListMsg.AddItem MsgListId(UBound(MsgListId)) & MsgListUser(UBound(MsgListUser)) & MsgListTime(UBound(MsgListTime))
ReDim Preserve MsgListTime(UBound(MsgListTime) + 1)
ReDim Preserve MsgListUser(UBound(MsgListUser) + 1)
ReDim Preserve MsgListId(UBound(MsgListId) + 1)
ReDim Preserve MsgListTxt(UBound(MsgListTxt) + 1)
ReDim Preserve MsgListRead(UBound(MsgListRead) + 1)
ReDim Preserve MsgListDel(UBound(MsgListDel) + 1)
ReDim Preserve MsgListRid(UBound(MsgListRid) + 1)

For xi = 0 To UBound(Ftalk)
If Ftalk(xi).Caption = "" Then GoTo exit2xi
tmpform = Left(Ftalk(xi).Caption, InStr(Ftalk(xi).Caption, " ") - 1)
If tmpuser = tmpform Then
GoTo exit1xi
End If
exit2xi:
Next
Call POPO(soundKey)
exit1xi:

For i = 0 To UBound(MsgList0)
If tmpuser = MsgList0(i) Then '找到重复的用户名
For ii = 0 To ListMsg.ListCount - 1
If tmpuser = Left(ListMsg.List(ii), InStr(ListMsg.List(ii), " ") - 1) Then
ListMsg.RemoveItem (ii)
MsgList1(i) = MsgList1(i) + 1
ListMsg.AddItem MsgList0(i) & " 有" & MsgList1(i) & "条新信息"
GoTo exit2
End If
Next
GoTo exit2
End If
Next
For ii = 0 To ListMsg.ListCount - 1
If ListMsg.List(ii) = "" Then GoTo next1:
If tmpuser = Left(ListMsg.List(ii), InStr(ListMsg.List(ii), " ") - 1) Then ListMsg.RemoveItem (ii)
next1:
Next
MsgList1(UBound(MsgList0)) = 1
MsgList0(UBound(MsgList0)) = tmpuser
ListMsg.AddItem MsgList0(UBound(MsgList0)) & " 有1条新信息"
ReDim Preserve MsgList0(UBound(MsgList0) + 1)
ReDim Preserve MsgList1(UBound(MsgList1) + 1)
exit2:
exit1:

Next '读信息
End Sub

Public Sub readfrilist(tmpfrilist As String) '读出好友列表
ListFri.Clear
Dim tmptxt As String
Dim ti As Long
Dim tmpti As Long
Dim tmptii As Long
tmptxt = "您现在有" '好友个数
ti = InStr(tmpfrilist, tmptxt)
If ti = 0 Then Exit Sub
tmptxt = Mid(tmpfrilist, ti + 6, InStr(ti, tmpfrilist, "个好友") - ti - 8)
tmptxt = Replace(tmptxt, """", "")
'MsgBox "您现在有" & tmptxt & "个好友"
If tmptxt = "0" Then Exit Sub
tmptii = Val(tmptxt)
ReDim vfrilist(tmptii) As String
'  MsgBox tmptxt
For tmpti = 1 To tmptii
tmptxt = "',nm:'" '好友个数
ti = InStr(ti, tmpfrilist, tmptxt)
tmptxt = Mid(tmpfrilist, ti + 6, InStr(ti, tmpfrilist, "'});") - ti - 6)
tmptxt = Replace(tmptxt, """", "")
tmptii = InStr(ti, tmpfrilist, "http://img.baidu.com/passport/")
If InStr(Mid(tmpfrilist, tmptii, 100), "/passport/icn_online.gif") > 0 Then
tmptxt = "@ " & tmptxt
Else
tmptxt = "_ " & tmptxt
End If
ti = ti + 50
vfrilist(tmpti) = tmptxt
ListFri.AddItem vfrilist(tmpti)
'MsgBox tmptxt
Next
End Sub
Public Sub readBadlist(tmpbadlist As String) '读出黑名单用户列表
ListBad.Clear
If InStr(tmpbadlist, "<title>百度个人中心_黑名单列表</title>") = 0 Then Exit Sub
If InStr(tmpbadlist, "<title>百度个人中心_黑名单列表</title>") > 0 And InStr(tmpbadlist, "无黑名单用户") > 0 Then Exit Sub
Dim tmptxt As String
Dim ti As Long
Dim tmpti As Long
ti = 1
tmptxt = "javascript:del('" '黑名单用户
Do
'If DOdebug = False Then GoTo exit1
ti = InStr(ti, tmpbadlist, tmptxt)
If ti = 0 Then GoTo exit1
tmpti = InStr(ti, tmpbadlist, "')")
ListBad.AddItem Mid(tmpbadlist, ti + 16, tmpti - ti - 16)
'ListBad.AddItem Len(Mid(tmpbadlist, ti + 16, tmpti - ti - 16))
ti = tmpti
Loop
exit1:
End Sub
Public Sub Getmsg0() '读取信息列表
Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
'http://msg.baidu.com/?cm=MailList&ct=18&tn=bmMessageList&rn=15&pn=0&rid=0
strUrl = "http://msg.baidu.com/"
txtpost = "cm=MailList&ct=18&tn=bmMessageList&rn=99&pn=0&rid=0"
strCookie = "Cookie: " & tmpCookie
'
Call MyPost(strUrl, txtpost, strCookie, "getmsg0")
End Sub
Public Sub Getmsg1() '读取信息列表
Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
'http://msg.baidu.com/?cm=MailList&ct=18&tn=bmMessageList&rn=15&pn=0&rid=0
strUrl = "http://msg.baidu.com/"
txtpost = "cm=MailList&ct=18&tn=bmMessageList&rn=99&pn=0&rid=1"
strCookie = "Cookie: " & tmpCookie
'
Call MyPost(strUrl, txtpost, strCookie, "getmsg1")
End Sub
Public Sub Getmsg2() '读取信息列表
Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
'http://msg.baidu.com/?cm=MailList&ct=18&tn=bmMessageList&rn=15&pn=0&rid=0
strUrl = "http://msg.baidu.com/"
txtpost = "cm=MailList&ct=18&tn=bmMessageList&rn=99&pn=0&rid=2"
strCookie = "Cookie: " & tmpCookie
'
Call MyPost(strUrl, txtpost, strCookie, "getmsg2")
End Sub
Public Sub GetFri() '读取好友列表
Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
'http://frd.baidu.com/?ct=28&cm=FriList&tn=bmPPFriend&un=yunfan2007
strUrl = "http://frd.baidu.com/"
txtpost = "ct=28&cm=FriList&tn=bmPPFriend&un=" & UTF(UserName.Text)
strCookie = "Cookie: " & tmpCookie

Call MyPost(strUrl, txtpost, strCookie, "getfri")
End Sub
Public Sub FriAdd(tmpFri As String)  '读取好友列表add
If tmpFri = "" Then MsgBox "没有选中用户": Exit Sub
Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
'http://frd.baidu.com/?cm=Commit&ct=29&tn=bmFriSubmit&un=用户名&word=好友名
strUrl = "http://frd.baidu.com/"
txtpost = "cm=Commit&op=1&ct=29&tn=bmFriSubmit&un=" & UTF(UserName.Text) & "&gns=&pt=0&word=" & UTF(tmpFri) & "&Submit=+%CC%ED%BC%D3%BA%C3%D3%D1+"
strCookie = "Cookie: " & tmpCookie

Call MyPost(strUrl, txtpost, strCookie, "friadd")
End Sub
Public Sub FriDel(tmpFri As String)  '读取好友列表del
If tmpFri = "" Then MsgBox "没有选中用户": Exit Sub
Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
'http://frd.baidu.com/?cm=commit&ct=29&op=3&tn=bmFriSubmit&un=用户名&dstun=好友名
strUrl = "http://frd.baidu.com/"
txtpost = "ct=29&cm=commit&op=3&gn=%C8%AB%B2%BF%BA%C3%D3%D1&dstun=" & UTF(tmpFri) & "&un=" & UTF(UserName.Text) & "&tn=bmFriSubmit&st=0&pt=0"
strCookie = "Cookie: " & tmpCookie

Call MyPost(strUrl, txtpost, strCookie, "fridel")
End Sub
Public Sub GetBad() '读取黑名单元列表
Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
'http://msg.baidu.com/?ct=18&tn=bmBlackList&cm=MailRe&rn=1000
strUrl = "http://msg.baidu.com/"
txtpost = "ct=18&tn=bmBlackList&cm=MailRe&rn=1000"
strCookie = "Cookie: " & tmpCookie

Call MyPost(strUrl, txtpost, strCookie, "getbad")
End Sub
Public Sub BadAdd(tmpFri As String) '读取黑名单元列表ADD
If tmpFri = "" Then MsgBox "没有选中用户": Exit Sub
Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
'http://msg.baidu.com/ct=22&cm=UsrblackAdd&tn=bmSubmit&co=好友名
strUrl = "http://msg.baidu.com/"
txtpost = "ct=22&cm=UsrblackAdd&tn=bmSubmit&co=" & UTF(tmpFri)
strCookie = "Cookie: " & tmpCookie

Call MyPost(strUrl, txtpost, strCookie, "badadd")
'MsgBox tmpFri
End Sub
Public Sub BadDel(tmpFri As String)  '读取黑名单元列表DEL
If tmpFri = "" Then MsgBox "没有选中用户": Exit Sub
Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
'http://msg.baidu.com/?ct=22&cm=UsrblackDel&tn=bmSubmit&co=好友名
strUrl = "http://msg.baidu.com/"
txtpost = "ct=22&cm=UsrblackDel&tn=bmSubmit&co=" & UTF(tmpFri)

strCookie = "Cookie: " & tmpCookie

Call MyPost(strUrl, txtpost, strCookie, "baddel")
End Sub
Public Sub SendMsg(K_SendTo As String, K_SendMsg As String, DoCmd As String) '发信息
Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
If K_SendMsg = "" Then K_SendMsg = "Hello,BaiDu."
If K_SendTo = "" Then K_SendTo = UserName.Text
strUrl = "http://msg.baidu.com/"
txtpost = "ct=22&cm=MailSend&tn=bmSubmit&rid=0&lu=&sn=" & UTF(K_SendTo) & "&co=" & K_SendMsg & "&button=%B7%A2"
strCookie = "Cookie: " & tmpCookie

Call MyPost(strUrl, txtpost, strCookie, DoCmd)
End Sub
Public Sub GetMsg(MsgId As Long) '取出信息

Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
'http://msg.baidu.com/?ct=18&cm=MailSend&tn=bmMessage&mid=
strUrl = "http://msg.baidu.com/"
txtpost = "ct=18&cm=MailSend&tn=bmMessage&mid=" & MsgId
strCookie = "Cookie: " & tmpCookie

Call MyPost(strUrl, txtpost, strCookie, "readmsg")
End Sub
Public Sub DelMsg(MsgId As Long, tmpRid As Long) '删除消息：
Dim strUrl As String '链接
Dim strCookie As String 'cookie
Dim txtpost As String
'删除消息：http://msg.baidu.com/?ct=22&cm=MailDel&tn=bmSubmit&co=消息号a
strUrl = "http://msg.baidu.com/"
txtpost = "ct=22&cm=MailDel&tn=bmSubmit&co=" & MsgId & "&rid=" & Trim(Str(tmpRid))
strCookie = "Cookie: " & tmpCookie

Call MyPost(strUrl, txtpost, strCookie, "delmsgid")
End Sub
Function readmsg(tmptext As String) As String
Dim tmptxt As String
Dim tmpmsg As String
Dim tmpti As Long
Dim ti As Long
tmpmsg = ""
ti = InStr(tmptext, "<!--HASREPLY-->")
If ti > 0 Then
tmptxt = Mid(tmptext, ti + 15, Len(tmptext) - ti - 14)
Else
ti = InStr(tmptext, "<!--STATUS OK-->")
'If ti = 0 Then MsgBox "NO MSG": Exit Function
If ti = 0 Then Exit Function
tmptxt = Mid(tmptext, ti + 16, Len(tmptext) - ti - 15)
End If
ti = InStr(tmptxt, "&#x")
If ti > 0 Then
tmptxt = tmptxt & ";"
tmptxt = Replace(tmptxt, vbCrLf, "/vbCrLf/;")
Dim tmpVhz As Variant
tmpVhz = Split(tmptxt, ";")
For ti = 0 To UBound(tmpVhz) - 1
If Len(tmpVhz(ti)) < 7 Then
        tmpmsg = tmpmsg & tmpVhz(ti) & ";"
    ElseIf Len(tmpVhz(ti)) = 7 Then
        If Left(tmpVhz(ti), 3) = "&#x" Then
            tmpmsg = tmpmsg & ChrW("&H" & Right(tmpVhz(ti), 4))
        Else
            tmpmsg = tmpmsg & tmpVhz(ti)
        End If
Else '大于7
    tmpti = InStr(tmpVhz(ti), "&#x")
    If tmpti > 0 Then
        If Left(Right(tmpVhz(ti), 7), 3) = "&#x" Then
        tmpmsg = tmpmsg & Left(tmpVhz(ti), tmpti - 1) & ChrW("&H" & Right(tmpVhz(ti), 4))
        Else
        tmpmsg = tmpmsg & tmpVhz(ti) & ";"
        End If
    Else
    tmpmsg = tmpmsg & tmpVhz(ti) & ";"
    End If
End If
Next
tmptxt = Left(tmpmsg, Len(tmpmsg) - 1)
tmptxt = Replace(tmptxt, "/vbCrLf/;", vbCrLf)
End If
readmsg = Replace(tmptxt, "<br>", vbCrLf)
readmsg = Replace(readmsg, "&nbsp;", " ")
End Function

Function UTF(strParameter As String) As String
  Dim s     As String
  Dim i     As Integer
  Dim intValue     As Integer
    
  Dim TmpData()     As Byte
    
          s = ""
          TmpData = StrConv(strParameter, vbFromUnicode)
          For i = 0 To UBound(TmpData)
                  intValue = TmpData(i)
                  If (intValue >= 48 And intValue <= 57) Or _
                          (intValue >= 65 And intValue <= 90) Or _
                          (intValue >= 97 And intValue <= 122) Then
                          s = s & Chr(intValue)
                  ElseIf intValue = 32 Then
                          s = s & "+"
                  Else
                          s = s & "%" & Hex(intValue)
                  End If
          Next i
          UTF = s
    
  End Function
Public Sub doNextPage()
Dim strUrl As String
Dim strCookie As String
strUrl = "http://hi.baidu.com/sys/uquerys/"
strCookie = "Cookie: " & tmpCookie
Call frmMain.MyPost(strUrl, NextPagePost, strCookie, "findfri")
End Sub

Public Sub FriListRead(tmptext As String)
Dim ii As Long
Dim ti As Long
Dim tmpFri As String
Dim tmpStr As String
'tmpText = InetListTxt(Index)
'tmptext = frmtmp.Text4.Text
If InStr(tmptext, "<TITLE>百度空间——找朋友</TITLE>") = 0 Then Exit Sub
If InStr(tmptext, "<TITLE>百度空间——找朋友</TITLE>") > 0 And InStr(tmptext, ">抱歉，没有找到符合条件的用户。</font>") > 0 Then Exit Sub
If InStr(tmptext, "<TITLE>百度空间——找朋友</TITLE>") > 0 And InStr(tmptext, ">下一页</a>&nbsp;") > 0 Then
frmList.cmdNextPage.Enabled = True
ii = InStr(1, tmptext, "</TBODY></TABLE>")
ti = InStr(ii, tmptext, ">下一页</a>&nbsp;")
tmpStr = Mid(tmptext, ii, ti - ii)
ti = InStrRev(tmpStr, "/sys/uquerys/?")
NextPagePost = Replace(Right(tmpStr, Len(tmpStr) - ti - 13), """", "")
'MsgBox NextPagePost
Else
frmList.cmdNextPage.Enabled = False
End If
 '搜索结果： '开始
 
 '<TD width="20%" align=middle vAlign=bottom>'用户数据开始
 'http://img.baidu.com/passport/icn_offline.gif" title="离线"
 'target=_blank> atkuai</A>&nbsp;</DIV></TD>'用户名
 '</A>&nbsp;</DIV></TD>'用户数据开始
 
 '&copy;2007 Baidu'结束
 
 'i=instr(tmpText,"搜索结果：")
 ii = 1
 Do
 ii = InStr(ii, tmptext, "align=middle vAlign=bottom>")
 If ii = 0 Then Exit Sub '没有列表
 ti = InStr(ii, tmptext, "</A>&nbsp;</DIV></TD>")
 tmpStr = Mid(tmptext, ii, ti - ii)
 If InStr(tmpStr, "icn_offline.gif") > 0 Then tmpFri = "_ " Else tmpFri = "@ "
 ii = ti '下一列表开始
 ti = InStrRev(tmpStr, "=_blank>")
 tmpStr = Right(tmpStr, Len(tmpStr) - ti - 7)
 tmpFri = tmpFri & Trim(tmpStr)
 frmList.List1.AddItem tmpFri
 frmList.Label1.Caption = "找到 " & frmList.List1.ListCount & "个用户。"
 Loop
 '结束
End Sub

Public Sub UserInfo(tmpFri As String)
If tmpFri = "" Then Exit Sub
Dim strUrl As String