一個帶采集遠程文章內容,保存圖片,生成文件等完整的采集功能
2024-05-04 11:00:18
供稿：網友
復制代碼 代碼如下:
'==================================================
'函數名：GetHttpPage
'作 用：獲取網頁源碼
'參 數：HttpUrl ------網頁地址
'==================================================
Function GetHttpPage(HttpUrl)
If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False$" Then
GetHttpPage="$False$"
Exit Function
End If
Dim Http
Set Http=server.createobject("MSX" & "ML2.XM" & "LHT" & "TP")
Http.open "GET",HttpUrl,False
Http.Send()
If Http.Readystate<>4 then
Set Http=Nothing
GetHttpPage="$False$"
Exit function
End if
GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
GetHTTPPage=replace(replace(GetHTTPPage , vbCr,""),vbLf,"")
Set Http=Nothing
If Err.number<>0 then
Err.Clear
End If
End Function
'==================================================
'函數名：BytesToBstr
'作 用：將獲取的源碼轉換為中文
'參 數：Body ------要轉換的變量
'參 數：Cset ------要轉換的類型
'==================================================
Function BytesToBstr(Body,Cset)
Dim Objstream
Set Objstream = Server.CreateObject("ad" & "odb.str" & "eam")
objstream.Type = 1
objstream.Mode =3
objstream.Open
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
set objstream = nothing
End Function
'==================================================
'函數名：PostHttpPage
'作 用：登錄
'==================================================
Function PostHttpPage(RefererUrl,PostUrl,PostData)
Dim xmlHttp
Dim RetStr
Set xmlHttp = CreateObject("Msx" & "ml2.XM" & "LHT" & "TP")
xmlHttp.Open "POST", PostUrl, False
XmlHTTP.setRequestHeader "Content-Length",Len(PostData)
xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xmlHttp.setRequestHeader "Referer", RefererUrl
xmlHttp.Send PostData
If Err.Number <> 0 Then
Set xmlHttp=Nothing
PostHttpPage = "$False$"
Exit Function
End If
PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
Set xmlHttp = nothing
End Function
'==================================================
'函數名：UrlEncoding
'作 用：轉換編碼
'==================================================
Function UrlEncoding(DataStr)
Dim StrReturn,Si,ThisChr,InnerCode,Hight8,Low8
StrReturn = ""
For Si = 1 To Len(DataStr)
ThisChr = Mid(DataStr,Si,1)
If Abs(Asc(ThisChr)) < &HFF Then
StrReturn = StrReturn & ThisChr
Else
InnerCode = Asc(ThisChr)
If InnerCode < 0 Then
InnerCode = InnerCode + &H10000
End If
Hight8 = (InnerCode And &HFF00)/ &HFF
Low8 = InnerCode And &HFF
StrReturn = StrReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
End If
Next
UrlEncoding = StrReturn
End Function
