爱华网如何只看汉风的帖子？
现在，我为大家写一个Vba代码，形成全是汉风1918的帖子。请按下面的步骤操作：
一、在桌面新建一个名为“汉风1918惊雷贴”文件夹，
二、在“汉风1918惊雷贴”文件夹里面新建一个名为“说明.txt”的文本文档，打开“说明.txt”，请输入下面“*******”以内的内容（可以不要“*******”）：
*******
1、打开”汉风1918惊雷贴.xlsm“
2、按 Alt＋F11，再按Ｆ５
3、等待出现”ＯＫ“对话框，关闭”ＯＫ“对话框。关闭”汉风1918惊雷贴.xlsm“文件
4、打开”汉风1918惊雷贴.html“，里面全是 汉风1918的帖子。
下载需要一些时间，要耐心等待。
注意：请不要更改本“说明”文件的末尾的数字，这是下载的起始贴号，记录你的下载历史。
*******
保存，关闭。
三、在“汉风1918惊雷贴”文件夹里面新建一个名为“汉风1918惊雷贴.xls”的Excel文档，打开“汉风1918惊雷贴.xls”，按 Alt＋F11，进入Excel的Vba环境，点击插入(N)，再点击模块(M)，把下面的的代码复制到模块1的窗口里面
Sub 汉风1918惊雷贴()
On Error Resume Next
Open ThisWorkbook.Path & "说明.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, NextLine
a = NextLine
Loop
Close #1
Open ThisWorkbook.Path & "汉风1918惊雷贴.html" For Append As #1
Dim temp
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", "http://" & "bbs.news.163.com/bbs/mil/1193698.html", False
.Send
tmp = Replace(.responseText, vbTab, " ")
temp = Split(Split(tmp, ".html""" & ">末页")(0), ",")
m = temp(UBound(temp))
Open ThisWorkbook.Path & "说明.txt" For Append As #2
Print #2, m
Print #2,
Close #2
If a < 1 Then
temp = Split(tmp, "javascript:BbsArticle.showUserinfoMenu")
For i = 0 To 1
Print #1, temp(i) & "javascript:BbsArticle.showUserinfoMenu"
Next i
Print #1, temp(2)
End If
For p = a + 1 To m
.Open "GET", "http://" & "bbs.news.163.com/bbs/mil/1193698.html", False
.Send
tmp = Replace(.responseText, vbTab, "")
temp = Split(tmp, "javascript:BbsArticle.showUserinfoMenu")
For i = 0 To UBound(temp) - 1
s = Trim(Split(temp(i), vbCrLf)(1))
If s = "汉风1918" Then
Print #1, "javascript:BbsArticle.showUserinfoMenu" & temp(i)
End If
Next i
Next p
End With
Close #1
MsgBox "ok"
End Sub
四、点击保存，不要关闭，然后按F5。现在已经在下载了，因为内容比较多，需要一些时间，请耐心等待。出现ＯＫ以后，就可以关闭了。祝你好运！
...........................
Sub 汉风1918惊雷贴()
On Error Resume Next
If Dir(ThisWorkbook.Path & "说明.txt", vbDirectory) = "" Then '如果没有“C:验证码图片”文件夹则创建它,“验证码图片”是我定义的一个名字,你可以改变它
MkDir ThisWorkbook.Path & "说明.txt"
Open ThisWorkbook.Path & "说明.txt" For Append As #2
Print #2, "1、打开”汉风1918惊雷贴.xlsm“"
Print #2, "2、按 Alt＋F11，再按Ｆ５"
Print #2, "3、等待出现”ＯＫ“对话框，关闭”ＯＫ“对话框。关闭”汉风1918惊雷贴.xlsm“文件"
Print #2, "4、打开”汉风1918惊雷贴.html“，里面全是 汉风1918的帖子。"
Print #2, "下载需要一些时间，要耐心等待。"
Print #2, "注意：请不要更改本“说明”文件的末尾的数字，这是下载的起始贴号，记录你的下载历史。"
Print #2, "0"
Close #2
End If
a = ""
Open ThisWorkbook.Path & "说明.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, NextLine
a = a & "@" & NextLine
Loop
Close #1
temp = Split(a, "@")
For i = UBound(temp) - 1 To 0 Step -1
If Len(temp(i)) > 0 Then a = temp(i)
If Len(temp(i)) > 10 Then a = 0
Next i
Open ThisWorkbook.Path & "汉风1918惊雷贴.html" For Append As #1
Dim temp
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", "http://" & "bbs.news.163.com/bbs/mil/1193698.html", False
.Send
Do Until .ReadyState = 4
DoEvents
Loop
tmp = Replace(.responseText, vbTab, " ")
temp = Split(Split(tmp, ".html""" & ">末页")(0), ",")
m = temp(UBound(temp))
Open ThisWorkbook.Path & "说明.txt" For Append As #2
Print #2, m
Print #2,
Close #2
If a < 1 Then
temp = Split(tmp, "javascript:BbsArticle.showUserinfoMenu")
For i = 0 To 1
Print #1, temp(i) & "javascript:BbsArticle.showUserinfoMenu"
Next i
Print #1, temp(2)
End If
For p = a + 1 To m
.Open "GET", "http://" & "bbs.news.163.com/bbs/mil/1193698," & p & ".html", False
.Send
Do Until .ReadyState = 4
DoEvents
Loop
tmp = Replace(.responseText, vbTab, "")
temp = Split(tmp, "javascript:BbsArticle.showUserinfoMenu")
For i = 0 To UBound(temp) - 1
s = Trim(Split(temp(i), vbCrLf)(1))
If s = "汉风1918" Then
Print #1, "javascript:BbsArticle.showUserinfoMenu" & temp(i)
End If
Next i
Next p
End With
Close #1
MsgBox "ok"
End Sub
..............................
Excel 2007 运行报错，修改了一下
Sub 汉风1918惊雷贴()
On Error Resume Next
If Dir(ThisWorkbook.Path & "说明.txt", vbDirectory) = "" Then '如果没有“C:验证码图片”文件夹则创建它,“验证码图片”是我定义的一个名字,你可以改变它
MkDir ThisWorkbook.Path & "说明.txt"
Open ThisWorkbook.Path & "说明.txt" For Append As #2
Print #2, "1、打开”汉风1918惊雷贴.xlsm“"
Print #2, "2、按 Alt＋F11，再按Ｆ５"
Print #2, "3、等待出现”ＯＫ“对话框，关闭”ＯＫ“对话框。关闭”汉风1918惊雷贴.xlsm“文件"
Print #2, "4、打开”汉风1918惊雷贴.html“，里面全是 汉风1918的帖子。"
Print #2, "下载需要一些时间，要耐心等待。"
Print #2, "注意：请不要更改本“说明”文件的末尾的数字，这是下载的起始贴号，记录你的下载历史。"
Print #2, "0"
Close #2
End If
'a = ""
a = 0
Open ThisWorkbook.Path & "说明.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, NextLine
a = a & "@" & NextLine
Loop
Close #1
temp = Split(a, "@")
For i = UBound(temp) - 1 To 0 Step -1
If Len(temp(i)) > 0 Then a = temp(i)
If Len(temp(i)) > 10 Then a = 0
Next i
Open ThisWorkbook.Path & "汉风1918惊雷贴.html" For Append As #1
'Dim temp
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", "http://" & "bbs.news.163.com/bbs/mil/1193698.html", False
.Send
Do Until .ReadyState = 4
DoEvents
Loop
tmp = Replace(.responseText, vbTab, " ")
temp = Split(Split(tmp, ".html""" & ">末页")(0), ",")
m = temp(UBound(temp))
Open ThisWorkbook.Path & "说明.txt" For Append As #2
Print #2, m
Print #2,
Close #2
If a < 1 Then
temp = Split(tmp, "javascript:BbsArticle.showUserinfoMenu")
For i = 0 To 1
Print #1, temp(i) & "javascript:BbsArticle.showUserinfoMenu"
Next i
Print #1, temp(2)
End If
For p = a + 1 To m
.Open "GET", "http://" & "bbs.news.163.com/bbs/mil/1193698," & p & ".html", False
.Send
Do Until .ReadyState = 4
DoEvents
Loop
tmp = Replace(.responseText, vbTab, "")
temp = Split(tmp, "javascript:BbsArticle.showUserinfoMenu")
For i = 0 To UBound(temp) - 1
s = Trim(Split(temp(i), vbCrLf)(1))
If s = "汉风1918" Then
Print #1, "javascript:BbsArticle.showUserinfoMenu" & temp(i)
End If
Next i
Next p
End With
Close #1
MsgBox "ok"
End Sub
.............................
引用35472楼gubulin的发言：
需要用VB生成EXE文件吗？
不需要生成EXE，这段代码是VBA代码直接在EXCEL中运行，需要注意的是：
1、EXCEL 2007 需要另存为 xlsm 格式，否则无法将本段代码保存到EXCEL中，下次运行仍然需要复制、粘贴。
2、不管 xlsm 文件保存在哪个目录，该目录下一定要新建 "说明.txt" 文件，否则会出现一个 "说明.txt"的文件夹
3、下载完后不要删除 "说明.txt" 文件，该文件中记载了最后下载的页码。
最终下载的文档接近8M
......................
