一键整理EH已回复历史帖,翻找借鉴自己的答案更方便！

coby001

wcymiss 发表于 2014-6-7 22:53
uid=******换成 username=用户名 也行的。省的去找uid了。
比如：uid=2617308换成 username=百度不到去谷歌 ...

另外，还是有个方法可以不登录就查看其他用户的回帖和主题的。估计是网页的一个小bug。。

这个不是Bug ，一般的，点击某人的Id，进入他的空间 => 主题 =>回复 （或主题），这样是能看到此人所有的帖子的。
当然，此用户如果设置了 隐藏隐私，就不可见了。

VBA万岁

帖上代码回公司再测试——公司电脑登陆不了本论坛，但可以浏览本论坛。
Option Explicit
Public oDoc As Object

Sub 已回复帖子()
    'On Error Resume Next
    Dim objXml As Object, i&, surl$, uid$
    Dim strText As String
    Set objXml = CreateObject("MSXML2.XMLHTTP")
    Set oDoc = CreateObject("htmlfile")
    Application.ScreenUpdating = False
    Sheet3.[A2:D65536] = ""
    i = 1
    surl = "http://search.excelhome.net/f/search?sId=6931017&ts=1402196193&mySign=50eefb9f"
    surl = Escape(surl) 'utf-8编码
    With objXml
            .Open "get", "http://search.excelhome.net/", False '登陆搜索页得到sid
            .send
            strText = .responseText '搜索页面
            
            surl = Replace(HtmlFilter(strText, "advanced?", """"), "amp;", "") '取得高级搜索页面地址关键sid
            surl = "http://search.excelhome.net/f/search?" & surl & "&extFids=&qs=txt.adv.a&rfh=1&q=&author=" & Escape(Sheet3.[h2]) & "&searchLevel=3&orderField=posted&timeLength=0&threadScope=all&orderType=desc"
            .Open "get", surl, False '登陆搜索页得到uid
            .send
             strText = .responseText '搜索结果页面
            uid = HtmlFilter(strText, "uid=", """") '取得UID
            [H3] = uid
    End With
    surl = "http://club.excelhome.net/home.php?mod=space&do=thread&view=&type=reply&from=space&uid=" & uid
    Do
        With objXml
            '.setRequestHeader "Cookie", cookie
            .Open "GET", surl & "&page=" & i, False '该页面不需登录也可查看到用户回复列表
            .send
            strText = .responseText
        End With
        GetDate strText
        i = i + 1
        If InStr(strText, "下一页") = 0 Or i = [h1] Then Exit Do '回复列表没有下一页时停止搜索下一页，为防过久运行无结果设置100页上限
    Loop
    ActiveSheet.UsedRange.RemoveDuplicates Columns:=2, Header:=xlYes '去重
    [A2] = 1
    i = [B65536].End(xlUp).Row
    [A2].AutoFill Destination:=Range("A2:A" & i), Type:=xlFillSeries
    MsgBox "共为您整理回复贴" & i - 1 & "个"
    Application.ScreenUpdating = True
    Set objXml = Nothing
    Set oDoc = Nothing
End Sub

Public Sub GetDate(Text$)
    Dim i&, j&, txt$, k&, objTab
    Dim r, arr
    oDoc.body.innerHTML = Text$
    Set objTab = oDoc.getElementsByTagName("table").Item(0).getElementsByTagName("th")
    k = objTab.Length - 1
    ReDim arr(1 To 3, 1 To k)
    For i = 1 To k '遍历回复列表
        With objTab
        'Debug.Print i, .Cells(1).innertex
            'Debug.Print i, .Item(i).innerText
            arr(2, i) = .Item(i).innerText
            arr(3, i) = "http://club.excelhome.net/" & HtmlFilter(.Item(i).innerHTML, "<A href=" & """" & "about:", """")
            arr(3, i) = Replace(arr(3, i), "amp;", "") '去除无效字符
        End With
    Next
    j = [B65536].End(xlUp).Offset(1).Row
    Cells(j, 1).Resize(k, 2) = Application.Transpose(arr)
    For i = 1 To UBound(arr, 2)
        ActiveSheet.Hyperlinks.Add Cells(j + i - 1, 2), arr(3, i)
    Next
End Sub

Public Function Escape(ByVal strText As String) As String     '如果值中带有非英文和数字，则需转换成%形式
    Dim js
    Set js = CreateObject("msscriptcontrol.scriptcontrol")
    js.Language = "JavaScript"
    Escape = js.Eval("encodeURI('" & Replace(strText, "'", "\'") & "');") 'utf-8
    'Escape = JS.Eval("escape('" & Replace(strText, "'", "\'") & "');")'Unicode
    'Escape = js.Eval("encodeURIComponent('" & Replace(strText, "'", "\'") & "');")'局部完全编码 包括特殊符号
End Function

Public Function HtmlFilter(ByVal htmlText$, label1$, label2$)
    '返回html字符串lable1和最近的lable2标签中的数据
    Dim pStart As Long, pStop As Long
    '开始位置，结束位置
    pStart = InStr(htmlText, label1) + Len(label1)
    '找到标签信息的起始位置
    If pStart <> 0 Then
        pStop = InStr(pStart, htmlText, label2)
        HtmlFilter = Mid(htmlText, pStart, pStop - pStart)
    End If
End Function

jpj123

不错的网抓作品