[Visual Basic] 纯文本查看 复制代码
path = "D:\核心价值观.{20D04FE0-3AEA-1069-A2D8-08002B30309D}"
u = "https://www.mzitu.com/all/"
s = HttpRequest(u, "GET", "", "", "")
Set html = CreateObject("htmlfile")
html.designMode = "on"
html.write s
For Each M In html.getElementsByTagName("p")
if M.classname = "url" then
For Each A in M.getElementsByTagName("a")
href = A.getAttribute("href")
if not(downlog(href, path, "read")) then
title = A.innertext
title = replace(replace(replace(replace(title,"\",""),"/",""),"*",""),"?","")
title = replace(replace(replace(replace(title,"<",""),">",""),"|",""),":","")
title = replace(replace(replace(title,chr(34),""),vblf,""),vbcr,"")
GetIMG href, title, path
wscript.sleep GetRandom(20000,30000)
end if
Next
end if
Next
msgbox "下载完成"
Sub GetIMG(url, title, path)
j = 1
do
nextpage = true
u = url & "/" & j
j = j + 1
r = HttpRequest(u, "GET", "", "", "")
Set htm = CreateObject("htmlfile")
htm.designMode = "on"
htm.write r
For Each D In htm.getElementsByTagName("div")
if D.classname = "main-image" then
Set img = D.getElementsByTagName("img")
src = img(0).getAttribute("src")
filename = right(src,len(src) - instrrev(src,"/"))
download src, title & "\" & filename, path
end if
if D.classname = "pagenavi" then
For Each P In D.getElementsByTagName("span")
if instr(P.innerText , "下一组") then
nextpage = false
end if
Next
end if
Next
wscript.sleep GetRandom(3000,6000)
loop until nextpage = false
downlog url, path, "write"
End Sub
Function HttpRequest(url, mode, cook, data, cookies)
'地址,GET/POST,getcookie/setcookie/download,请求数据, cookies
on error resume next
Set cHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
With cHttp
.SetTimeouts 80000, 80000, 80000, 80000
.Open mode, url, False
If cook = "setcookie" Then .SetRequestHeader "Cookie", cookies
.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/80.0.3987.122 Safari/537.36"
if mode = "POST" then
.SetRequestHeader "content-Type", "application/x-www-form-urlencoded"
.SetRequestHeader "Content-Length", Len(data)
end if
.SetRequestHeader "Referer", url
.SetRequestHeader "Cache-Control", "no-cache"
.SetRequestHeader "Connection", "keep-alive"
.Send data
If .WaitForResponse Then
If .Status = 200 Then
If cook = "getcookie" Then
HttpRequest = GetCookie(.getAllResponseHeaders)
ElseIf cook = "download" then
HttpRequest =.responseBody
Else
HttpRequest =.responseText
End If
End If
End If
End With
End Function
Function GetCookie(str)
a = InStr(str, "Set-Cookie: ")
If a = 0 Then
GetCookie = ""
Else
b = InStr(a, str, ";")
c = Mid(str, a + 12, b - a - 11)
Cookie = c
Do
d = InStr(b, str, "Set-Cookie: ")
If d = 0 Then Exit Do
e = InStr(d, str, ";")
f = Mid(str, d + 12, e - d - 11)
b = e
Cookie = Cookie & " " & f
Loop
GetCookie = Cookie
End If
End Function
Sub download(url, target, path)
Set fso=CreateObject("scripting.FileSystemObject")
target = path & "\" & target
p = left(target,instrrev(target,"\"))
If Not FSO.FolderExists(p) Then fso.CreateFolder(p)
Const adTypeBinary = 1
Const adSaveCreateOverWrite = 2
Set ado = createobject("Adodb.Stream")
ado.Type = adTypeBinary
ado.Open
ado.Write HttpRequest(url, "GET", "download", "", "")
ado.SaveToFile target, 2
ado.Close
End Sub
Function downlog(u, path, mode)
Set fso=CreateObject("scripting.FileSystemObject")
If Not FSO.FolderExists(path) Then fso.CreateFolder(path)
file = path & "\download.log"
if mode = "read" then
if fso.FileExists(file) then
set f = fso.opentextfile(file)
logs = f.readall
if instr(logs, u) then downlog = true else downlog = false
f.close
else
set f = fso.createtextfile(file)
f.writeline ""
f.close
downlog = false
end if
else
set f = fso.opentextfile(file,8)
f.writeline u
f.close
end if
End Function
Function GetRandom(min,max)
Randomize
GetRandom = Int((max - min + 1) * Rnd + min)
End Function