28,409
社区成员




'页面抓取
Function getHTTPPage(url)
On Error Resume Next
dim Http
set Http=server.createobject("MSXML2.ServerXMLHTTP")
Http.open "GET",url,false,"",""
Http.send()
if Http.readystate<>4 then
getHTTPPage(url)
Exit function
else
If Http.status <> 200 then
getHTTPPage = ""
Exit Function
End If
End If
getHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
set http=nothing
If err.number<>0 then err.Clear
End Function
Function BytesToBstr(body,Cset)
dim objstream
set objstream = Server.CreateObject("adodb.stream")
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
'End
Sub HTML_patterns(show,fname,folder)
'show页在地址,fname文件名,folder文件路径
On Error Resume Next
filepath = folder&fname
'建产文件夹
set myfso = CreateObject("Scripting.FileSystemObject")
If myfso.FolderExists(Server.MapPath(folder)) = False Then
myfso.CreateFolder Server.MapPath(folder)
End If
set myfso=nothing
If show <> "" then
content = getHTTPPage(show)
Else
Response.write "<a href=""#"" onclick=""javascript:location.reload();"">生成静态页失败。请点击此处重新生成。</a>"
Response.end()
Exit Sub
End If
If Replace(content," ","") <> "" then
'Response.write "正在生成页页,请不要刷新......"
Else
Response.write "<a href=""#"" onclick=""javascript:location.reload();"">生成静态页失败。请点击此处重新生成。</a>"
Response.end()
End If
'Response.write content
'生成HTML页面
Set fso = Server.CreateObject("Scripting.FileSystemObject")
fso.CreateFolder(Server.MapPath(folder))
Set fout = fso.CreateTextFile(Server.MapPath(filepath),true,false)
fout.WriteLine CreateCode(content)
fout.close
Files = true
End Sub