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

百度不到去谷歌 · 发表于 2014-6-6 19:17

本帖最后由百度不到去谷歌于 2014-6-8 18:03 编辑

最近回答问题发现很多都是曾经答过的类似问题但是回去翻历史回复贴却发现EH的历史列表不好使
EH的已回复贴是按每次的回复都记录的不是按主题排重复的就很多了另外分页很多查找起来也慢
我就想直接在全部列表里一部查找到位啊
反正最近也写了好多获取网页的代码干脆自己写一个算了
一次性获取所有历史回复配合excle自己的筛选功能就很容易找到想要的历史回复了
另外要做网页获取的童鞋也可以参考一下这个代码代码写的比较随意高手就别取笑了
希望有需要的人能用到
注意：请将代码中的网址前半部分换为你登陆以后在个人页面中查看回复项目时的网址
主要是uid每个人不同http://club.excelhome.net/home.php?mod=space&uid=2617308&do=thread&view=me&type=reply&orde
QQ截图20140606191555.jpg

1EH本人回复帖子.rar (79.69 KB, 下载次数: 67)

受wcymiss 说到可以不登陆获取程序的启发研究一上午终于成功最新成果只需输入用户名就可以获取该用户所有回复列表了
不知道是不是和wcymiss 利用的一样的原理也许是网站bug 要是修复了可能会失效不过作为学习的态度我还是发出来吧
具体细节就不多讲了详见最新附件
附件经网友测试有问题现已更新经测试一般人回复列表均可以得到个别人回复列表无法得到目前原因不明

1EH查找某人回复帖子所有列表-无需登录.rar (51.59 KB, 下载次数: 174)

百度不到去谷歌 · 发表于 2014-6-6 19:25

代码如下

Option Explicit
Public oDoc As Object '用全局document对象避免每次调用都创建新的
Sub 已回复帖子()
'On Error Resume Next
Dim objXml As Object, i&
Dim strText As String
Set objXml = CreateObject("MSXML2.XMLHTTP")
Set oDoc = CreateObject("htmlfile")
Application.ScreenUpdating = False
Sheet3.[A2:D65536] = ""
i = 1
Do
With objXml
.Open "GET", "http://club.excelhome.net/home.php?mod=space&uid=2617308&do=thread&view=me&type=reply&order=dateline&page=" & i & "&x=" & Rnd, 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(3).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 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

复制代码

suwenkai · 发表于 2014-6-6 19:29

楼主是高手啊。

sunny_8848 · 发表于 2014-6-6 19:48

非常感谢楼主。ActiveSheet.UsedRange.RemoveDuplicates Columns:=2, Header:=xlYes '去重，这句代码运行错误请楼主看看('On Error Resume Next取消注释可以查询，不知道结果是否是全部正确）

sunny_8848 · 发表于 2014-6-6 19:56

有些帖子本人都么有回复过也在列表中，不知道是否可以按用户名和密码搜索自己回复过的帖子

百度不到去谷歌 · 发表于 2014-6-6 20:01

本帖最后由百度不到去谷歌于 2014-6-6 20:04 编辑

sunny_8848 发表于 2014-6-6 19:56
有些帖子本人都么有回复过也在列表中，不知道是否可以按用户名和密码搜索自己回复过的帖子

恩我忘了一点每个人登陆后的网址不一样你把代码中的网址前半部分换为
你登陆后在查看本人回复的那个网址的前半部分应该就可以了应该只需要替换那个uid
QQ截图20140606200107.jpg

liucqa · 发表于 2014-6-6 23:19

你可以写一个完整的版本，根据登录信息，下载回复的帖子

百度不到去谷歌 · 发表于 2014-6-6 23:25

本帖最后由百度不到去谷歌于 2014-6-7 08:41 编辑

liucqa 发表于 2014-6-6 23:19
你可以写一个完整的版本，根据登录信息，下载回复的帖子

刚才倒是发现不用登陆也能得到回帖数据了只要知道某人的uid即可今天有点晚了
改天有空再写了
还是要登录才行了登陆要点验证码太难了
有这个需求的我想都是已经登陆的用户吧
只要知道uid就行了就是自己eh空间地址的那串数字
比如http://club.excelhome.net/home.php?mod=space&uid=2617308后面就是我的uid
登陆后想查询别人的回复贴只需要去别人空间查看uid 修改这个uid即可
当然你也可以用一个单元格存uid传递到程序里

yf_home · 发表于 2014-6-7 09:13

这个不错，关注一下。

VBA万岁 · 发表于 2014-6-7 11:09

百度君真是有才！......

		自动登录	找回密码
密码			免费注册

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

评分

点评

评分