<%
'========================================
class EngineerSearch
'老龙:laolong9999@sina.com
':模拟XML获取http标记资源(用过之后就知道为什么XML有用:))
'利用引擎搜索(显示引擎信息或其超连接网站上的信息或直接一个指定页面的相关信息,利用正则和xmlHttp,
'程序的使用需要会构造正则)
'---------------------------------------------------------------
private oReg,oxmlHttp'一个正则,一个微软xmlhttp
'---------------------------------------------------------------
public sub class_initialize()'对象建立触发
set oReg=new regExp
oReg.Global=true
oReg.IgnoreCase=true
set oXmlHttp=server.createobject("Microsoft.XmlHttp")
end sub
'---------------------------------------------------------------
public sub class_terminate()'对象销毁触发
set oReg=nothing'必须手动释放class内的自建对象,asp只自动释放由class定义的对象
set oXmlHttp=nothing
If typename(tempReg)<>"nothing" then'方法体内的对象释放资源
set tempReg=nothing
end if
end sub
'---------------------------------------------------------------
'引擎级搜索
public function engineer(url,EngineerReg)
'功能介绍:获得url的返回信息(通常用于引擎查找),提取其中的EngineerReg的特定信息,返回matches集合到
'函数名。获得url查询结果,搜寻出用engineerReg正则定义的结果,生成一个matches集合,
'由于无法建立集合及操作集合个数(vbscript),最好再自己遍历集合,也可以考虑二维数组
dim strConent
strContent=oXmlHttp.open("get",url,false)
on error resume next
oXmlHttp.send()
if err.number<>0 then
exit function
end if
strContent=bytes2BSTR(oXmlHttp.responseBody)
if isnull(EngineerReg) then
engineer=AbsoluteURL(strContent,url)
else
oReg.Pattern=EngineerReg
set engineer=oReg.Execute(AbsoluteURL(strContent,url))
end if
end function
'---------------------------------------------------------------
'汉字编码,(网人)
public Function bytes2BSTR(vIn)
strReturn = ""
For i = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn,i,1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn,i+1,1))
strReturn = strReturn & Chr (CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
i = i + 1
End If
Next
bytes2BSTR = strReturn
End Function
'---------------------------------------------------------------
public Function SearchReplace(strContent,ReplaceReg,ResultReg)
'替换,将strContent中的replaceReg描述的字符串用resultReg描述的替换,返回到searchReplace去
'将正则的replace封装了。
oReg.Pattern=ReplaceReg
SearchReplace=oReg.replace(strContent,ResultReg)
End Function
'---------------------------------------------------------------
public Function AbsoluteURL(strContent,byval url)
'将strContent中的相对URL变成oXmlHttp中指定的url的绝对地址(http/https/ftp/mailto:)
'正则可以修改修改。
dim tempReg
set tempReg=new RegExp
tempReg.IgnoreCase=true
tempReg.Global=true
tempReg.Pattern="(^.*\/).*$"'含文件名的标准路径http://www.wrclub.net/default.aspx
Url=tempReg.replace(url,"$1")
tempReg.Pattern="((?:src|href).*?=[\'\u0022](?!ftp|http|https|mailto))"
AbsoluteURL=tempReg.replace(strContent,"$1"+Url)
set tempReg=nothing
end Function
'---------------------------------------------------------------
end class
'========================================
%>
<%'例子
Response.CharSet = "GB2312"
dim mySearch
set mySearch=new EngineerSearch
'URL一定是包含文件扩展名的完整地址,结果是集合,集合中的每个项目是数组,应该这样引用子查询:myMatches(0).subMatches(0)
set myMatches=mySearch.engineer("http://www.wrclub.net/default.aspx","<img.*?>")
if myMatches.count=0 Then
response.write "没有你正则的字符串"
end if
if myMatches.count>0 then
response.write myMatches.count&"<br>"
for each key in myMatches
response.write key.firstindex&":"&cstr(key.value)&"<br>"
next
end if
%>
if createdir(localaddr) = false then
response.Write "创建目录失败,请检查目录权限"
response.End
end if
response.Write Convert2LocalAddr(url,localaddr,localdir)
function Convert2LocalAddr(url,localaddr,localdir)
'参数说明
'url 页面地址
'localaddr 保存本地的物理地址
'localdir 相对路径
strContent = getHTTPPage(url)
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<img.+?>"
Set Matches =objRegExp.Execute(strContent)
For Each Match in Matches
RetStr = RetStr & GetRemoteImages(Match.value)
Next
ImagesArray=split(RetStr,"||")
RemoteImage=""
LocalImage=""
for i=1 to ubound(ImagesArray)
if ImagesArray(i)<>"" and instr(RemoteImage,ImagesArray(i))<1 then
fname=baseurl&cstr(i&mid(ImagesArray(i),instrrev(ImagesArray(i),".")))
ImagesFileName = ImagesArray(i)
AllowFileExtArray = split(AllowFileExt,"|")
isGetFile = false
for tmp = 0 to ubound(AllowFileExtArray)
if lcase(GetFileExt(ImagesFileName)) = ALlowFileExtArray(tmp) then
isGetFile=True
end if
next
if isGetFile = true then
newfilename = GenerateRandomFileName(fname)
call Save2Local(ImagesFileName,localaddr & "/" & newfilename)
RemoteImage=RemoteImage&"||"& ImagesFileName
LocalImage=LocalImage&"||" & localdir & newfilename
end if
end if
next
arrnew=split(LocalImage,"||")
arrall=split(RemoteImage,"||")
for i=1 to ubound(arrnew)
strContent=replace(strContent,arrall(i),arrnew(i))
next
Convert2LocalAddr = strContent
end function
function GetRemoteImages(str)
Set objRegExp1 = New Regexp
objRegExp1.IgnoreCase = True
objRegExp1.Global = True
objRegExp1.Pattern = "http://.+? "
set mm=objRegExp1.Execute(str)
For Each Match1 in mm
tmpaddr = left(Match1.value,len(Match1.value)-1)
GetRemoteImages=GetRemoteImages&"||" & replace(replace(tmpaddr,"""",""),"'","")
next
end function
function getHTTPPage(url)
on error resume next
dim http
set http=Server.createobject("Msxml2.XMLHTTP")
Http.open "GET",url,false
Http.send()
if Http.readystate<>4 then exit function
getHTTPPage=bytes2BSTR(Http.responseBody)
set http=nothing
if err.number<>0 then err.Clear
end function
Function bytes2BSTR(vIn)
dim strReturn
dim i,ThisCharCode,NextCharCode
strReturn = ""
For i = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn,i,1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn,i+1,1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
i = i + 1
End If
Next
bytes2BSTR = strReturn
End Function
function getHTTPimg(url)
on error resume next
dim http
set http=server.createobject("MSXML2.XMLHTTP")
Http.open "GET",url,false
Http.send()
if Http.readystate<>4 then exit function
getHTTPimg=Http.responseBody
set http=nothing
if err.number<>0 then err.Clear
end function
function Save2Local(from,tofile)
dim geturl,objStream,imgs
geturl=trim(from)
imgs=gethttpimg(geturl)
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type =1
objStream.Open
objstream.write imgs
objstream.SaveToFile tofile,2
objstream.Close()
set objstream=nothing
end function
function geturlencodel(byval url)'中文文件名转换
Dim i,code
geturlencodel=""
if trim(Url)="" then exit function
for i=1 to len(Url)
code=Asc(mid(Url,i,1))
if code<0 Then code = code + 65536
If code>255 Then
geturlencodel=geturlencodel&"%"&Left(Hex(Code),2)&"%"&Right(Hex(Code),2)
else
geturlencodel=geturlencodel&mid(Url,i,1)
end if
next
end function
Function GenerateRandomFileName(ByVal szFilename) '根据原文件名,自动以日期YYYY-MM-DD-RANDOM格式生成新文件名
Randomize
ranNum = Int(90000 * Rnd) + 10000
If Month(Now) < 10 Then c_month = "0" & Month(Now) Else c_month = Month(Now)
If Day(Now) < 10 Then c_day = "0" & Day(Now) Else c_day = Day(Now)
If Hour(Now) < 10 Then c_hour = "0" & Hour(Now) Else c_hour = Hour(Now)
If Minute(Now) < 10 Then c_minute = "0" & Minute(Now) Else c_minute = Minute(Now)
If Second(Now) < 10 Then c_second = "0" & Second(Now) Else c_second = Minute(Now)
fileExt_a = Split(szFilename, ".")
FileExt = LCase(fileExt_a(UBound(fileExt_a)))
GenerateRandomFileName = Year(Now) & c_month & c_day & c_hour & c_minute & c_second & "_" & ranNum & "." & FileExt
End Function
Function CreateDIR(ByVal LocalPath) '建立目录的程序,如果有多级目录,则一级一级的创建
On Error Resume Next
LocalPath = Replace(LocalPath, "\", "/")
Set FileObject = server.CreateObject("Scripting.FileSystemObject")
patharr = Split(LocalPath, "/")
path_level = UBound(patharr)
For I = 0 To path_level
If I = 0 Then pathtmp = patharr(0) & "/" Else pathtmp = pathtmp & patharr(I) & "/"
cpath = Left(pathtmp, Len(pathtmp) - 1)
If Not FileObject.FolderExists(cpath) Then FileObject.CreateFolder cpath
Next
Set FileObject = Nothing
If Err.Number <> 0 Then
CreateDIR = False
Err.Clear
Else
CreateDIR = True
End If
End Function
function GetfileExt(byval filename)
fileExt_a=split(filename,".")
GetfileExt=lcase(fileExt_a(ubound(fileExt_a)))
end function
%>
Function findurl(thisurl)
if thisurl <> "" Then
findurl=""
strlen=InStr(8,thisurl,"/")
If strlen=0 Then strlen =1
findurl=Mid(thisurl,strlen,28)
end if
end Function
function findurlpath(thisurl)
thisurl = replace(thisurl,"//","@@")
ary_tmp = split(thisurl,"/")
for tmp = 0 to ubound(ary_tmp)
if tmp < ubound(ary_tmp) then
urltmp = urltmp & "/" & ary_tmp(tmp)
end if
next
urltmp = right(urltmp,len(urltmp)-1)
findurlpath = replace(urltmp,"@@","//") & "/"
end function
function getHTTPPage(url)
on error resume next
dim http
set http=Server.createobject("Msxml2.XMLHTTP")
Http.open "GET",url,false
Http.send()
if Http.readystate<>4 then exit function
getHTTPPage=bytes2BSTR(Http.responseBody)
set http=nothing
if err.number<>0 then err.Clear
end function
Function bytes2BSTR(vIn)
dim strReturn
dim i,ThisCharCode,NextCharCode
strReturn = ""
For i = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn,i,1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn,i+1,1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
i = i + 1
End If
Next
bytes2BSTR = strReturn
End Function