一个带采集远程文章内容,保存图片,生成文件等完整的采集功能

'==================================================
'函数名：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

'==================================================
'函数名：getbody
'作 用：截取字符串
'参 数：constr ------将要截取的字符串
'参 数：startstr ------开始字符串
'参 数：overstr ------结束字符串
'参 数：inclul ------是否包含startstr
'参 数：inclur ------是否包含overstr
'==================================================
function getbody(constr,startstr,overstr,inclul,inclur)
if constr="$false$" or constr="" or isnull(constr)=true or startstr="" or isnull(startstr)=true or overstr="" or isnull(overstr)=true then
getbody="$false$"
exit function
end if
dim constrtemp
dim start,over
constrtemp=lcase(constr)
startstr=lcase(startstr)
overstr=lcase(overstr)
start = instrb(1, constrtemp, startstr, vbbinarycompare)
if start<=0 then
getbody="$false$"
exit function
else
if inclul=false then
start=start+lenb(startstr)
end if
end if
over=instrb(start,constrtemp,overstr,vbbinarycompare)
if over<=0 or over<=start then
getbody="$false$"
exit function
else
if inclur=true then
over=over+lenb(overstr)
end if
end if
getbody=midb(constr,start,over-start)
end function



'==================================================
'函数名：getarray
'作 用：提取链接地址，以$array$分隔
'参 数：constr ------提取地址的原字符
'参 数：startstr ------开始字符串
'参 数：overstr ------结束字符串
'参 数：inclul ------是否包含startstr
'参 数：inclur ------是否包含overstr
'==================================================
function getarray(byval constr,startstr,overstr,inclul,inclur)
if constr="$false$" or constr="" or isnull(constr)=true or startstr="" or overstr="" or isnull(startstr)=true or isnull(overstr)=true then
getarray="$false$"
exit function
end if
dim tempstr,tempstr2,objregexp,matches,match
tempstr=""
set objregexp = new regexp
objregexp.ignorecase = true
objregexp.global = true
objregexp.pattern = "("&startstr&").+?("&overstr&")"
set matches =objregexp.execute(constr)
for each match in matches
tempstr=tempstr & "$array$" & match.value
next
set matches=nothing

if tempstr="" then
getarray="$false$"
exit function
end if
tempstr=right(tempstr,len(tempstr)-7)
if inclul=false then
objregexp.pattern =startstr
tempstr=objregexp.replace(tempstr,"")
end if
if inclur=false then
objregexp.pattern =overstr
tempstr=objregexp.replace(tempstr,"")
end if
set objregexp=nothing
set matches=nothing

tempstr=replace(tempstr,"""","")
tempstr=replace(tempstr,"'","")
tempstr=replace(tempstr," ","")
tempstr=replace(tempstr,"(","")
tempstr=replace(tempstr,")","")

if tempstr="" then
getarray="$false$"
else
getarray=tempstr
end if
end function


'==================================================
'函数名：definiteurl
'作 用：将相对地址转换为绝对地址
'参 数：primitiveurl ------要转换的相对地址
'参 数：consulturl ------当前网页地址
'==================================================
function definiteurl(byval primitiveurl,byval consulturl)
dim contemp,pritemp,pi,ci,priarray,conarray
if primitiveurl="" or consulturl="" or primitiveurl="$false$" or consulturl="$false$" then
definiteurl="$false$"
exit function
end if
if left(lcase(consulturl),7)<>"http://" then
consulturl= "http://" & consulturl
end if
consulturl=replace(consulturl,"\","/")
consulturl=replace(consulturl,"://",":\\")
primitiveurl=replace(primitiveurl,"\","/")

if right(consulturl,1)<>"/" then
if instr(consulturl,"/")>0 then
if instr(right(consulturl,len(consulturl)-instrrev(consulturl,"/")),".")>0 then
else
consulturl=consulturl & "/"
end if
else
consulturl=consulturl & "/"
end if
end if
conarray=split(consulturl,"/")

if left(lcase(primitiveurl),7) = "http://" then
definiteurl=replace(primitiveurl,"://",":\\")
elseif left(primitiveurl,1) = "/" then
definiteurl=conarray(0) & primitiveurl
elseif left(primitiveurl,2)="./" then
primitiveurl=right(primitiveurl,len(primitiveurl)-2)
if right(consulturl,1)="/" then
definiteurl=consulturl & primitiveurl
else
definiteurl=left(consulturl,instrrev(consulturl,"/")) & primitiveurl
end if
elseif left(primitiveurl,3)="../" then
do while left(primitiveurl,3)="../"
primitiveurl=right(primitiveurl,len(primitiveurl)-3)
pi=pi+1
loop
for ci=0 to (ubound(conarray)-1-pi)
if definiteurl<>"" then
definiteurl=definiteurl & "/" & conarray(ci)
else
definiteurl=conarray(ci)
end if
next
definiteurl=definiteurl & "/" & primitiveurl
else
if instr(primitiveurl,"/")>0 then
priarray=split(primitiveurl,"/")
if instr(priarray(0),".")>0 then
if right(primitiveurl,1)="/" then
definiteurl="http:\\" & primitiveurl
else
if instr(priarray(ubound(priarray)-1),".")>0 then
definiteurl="http:\\" & primitiveurl
else
definiteurl="http:\\" & primitiveurl & "/"
end if
end if
else
if right(consulturl,1)="/" then
definiteurl=consulturl & primitiveurl
else
definiteurl=left(consulturl,instrrev(consulturl,"/")) & primitiveurl
end if
end if
else
if instr(primitiveurl,".")>0 then
if right(consulturl,1)="/" then
if right(lcase(primitiveurl),3)=".cn" or right(lcase(primitiveurl),3)="com" or right(lcase(primitiveurl),3)="net" or right(lcase(primitiveurl),3)="org" then
definiteurl="http:\\" & primitiveurl & "/"
else
definiteurl=consulturl & primitiveurl
end if
else
if right(lcase(primitiveurl),3)=".cn" or right(lcase(primitiveurl),3)="com" or right(lcase(primitiveurl),3)="net" or right(lcase(primitiveurl),3)="org" then
definiteurl="http:\\" & primitiveurl & "/"
else
definiteurl=left(consulturl,instrrev(consulturl,"/")) & "/" & primitiveurl
end if
end if
else
if right(consulturl,1)="/" then
definiteurl=consulturl & primitiveurl & "/"
else
definiteurl=left(consulturl,instrrev(consulturl,"/")) & "/" & primitiveurl & "/"
end if
end if
end if
end if
if left(definiteurl,1)="/" then
definiteurl=right(definiteurl,len(definiteurl)-1)
end if
if definiteurl<>"" then
definiteurl=replace(definiteurl,"//","/")
definiteurl=replace(definiteurl,":\\","://")
else
definiteurl="$false$"
end if
end function

'==================================================
'函数名：replacesaveremotefile
'作 用：替换、保存远程图片
'参 数：constr ------ 要替换的字符串
'参 数：savetf ------ 是否保存文件，false不保存，true保存
'参 数: tisturl------ 当前网页地址
'==================================================
function replacesaveremotefile(constr,installpath,strchanneldir,savetf,tisturl)
if constr="$false$" or constr="" or installpath="" or strchanneldir="" then
replacesaveremotefile=constr
exit function
end if
dim tempstr,tempstr2,tempstr3,re,matches,match,tempi,temparray,temparray2

set re = new regexp
re.ignorecase = true
re.global = true
re.pattern ="<img.+?>"
set matches =re.execute(constr)
for each match in matches
if tempstr<>"" then
tempstr=tempstr & "$array$" & match.value
else
tempstr=match.value
end if
next
if tempstr<>"" then
temparray=split(tempstr,"$array$")
tempstr=""
for tempi=0 to ubound(temparray)
re.pattern ="src\s*=\s*.+?\.(gifjpgbmpjpegpsdpngsvgdxfwmftiff)"
set matches =re.execute(temparray(tempi))
for each match in matches
if tempstr<>"" then
tempstr=tempstr & "$array$" & match.value
else
tempstr=match.value
end if
next
next
end if
if tempstr<>"" then
re.pattern ="src\s*=\s*"
tempstr=re.replace(tempstr,"")
end if
set matches=nothing
set re=nothing
if tempstr="" or isnull(tempstr)=true then
replacesaveremotefile=constr
exit function
end if
tempstr=replace(tempstr,"""","")
tempstr=replace(tempstr,"'","")
tempstr=replace(tempstr," ","")
dim remotefileurl,savepath,pathtemp,dtnow,strfilename,strfiletype,arrsavefilename,rannum,arr_path
dtnow=now()
'***********************************
if savetf=true then
savepath=installpath&strchanneldir
if checkdir(installpath & strchanneldir)=false then
if not createmultifolder(installpath & strchanneldir) then
response.write installpath & strchanneldir&"目录创建失败"
savetf=false
end if
end if
end if

'去掉重复图片开始
temparray=split(tempstr,"$array$")
tempstr=""
for tempi=0 to ubound(temparray)
if instr(lcase(tempstr),lcase(temparray(tempi)))<1 then
tempstr=tempstr & "$array$" & temparray(tempi)
end if
next
tempstr=right(tempstr,len(tempstr)-7)
temparray=split(tempstr,"$array$")
'去掉重复图片结束

response.write "<br>发现图片:<br>"&replace(tempstr,"$array$","<br>")

'转换相对图片地址开始
tempstr=""
for tempi=0 to ubound(temparray)
tempstr=tempstr & "$array$" & definiteurl(temparray(tempi),tisturl)
next
tempstr=right(tempstr,len(tempstr)-7)
tempstr=replace(tempstr,chr(0),"")
temparray2=split(tempstr,"$array$")
tempstr=""
'转换相对图片地址结束

'图片替换/保存
set re = new regexp
re.ignorecase = true
re.global = true

for tempi=0 to ubound(temparray2)
'********************************
remotefileurl=temparray2(tempi)
if remotefileurl<>"$false$" and savetf=true then'保存图片
arrsavefilename = split(remotefileurl,".")
strfiletype=lcase(arrsavefilename(ubound(arrsavefilename)))'文件类型
if strfiletype="asp" or strfiletype="asa" or strfiletype="aspx" or strfiletype="cer" or strfiletype="cdx" or strfiletype="exe" or strfiletype="rar" or strfiletype="zip" then
uploadfiles=""
replacesaveremotefile=constr
exit function
end if

randomize
rannum=int(900*rnd)+100
strfilename = year(dtnow) & right("0" & month(dtnow),2) & right("0" & day(dtnow),2) & right("0" & hour(dtnow),2) & right("0" & minute(dtnow),2) & right("0" & second(dtnow),2) & rannum & "." & strfiletype
re.pattern =temparray(tempi)
response.write "<br>保存到本地地址:"&installpath & strchanneldir & strfilename
if saveremotefile(installpath & strchanneldir & strfilename,remotefileurl,remotefileurl)=true then
response.write "<font color=blue>成功</font><br>"
pathtemp=installpath & strchanneldir & strfilename
constr=re.replace(constr,pathtemp)
re.pattern=installpath&strchanneldir
uploadfiles=uploadfiles & "" & installpath & strchanneldir & strfilename
else
pathtemp=remotefileurl
constr=re.replace(constr,pathtemp)
end if
elseif remotefileurl<>"$false$" and savetf=false then'不保存图片
re.pattern =temparray(tempi)
constr=re.replace(constr,remotefileurl)
end if
'********************************
next
set re=nothing
replacesaveremotefile=constr
end function

'==================================================
'函数名：replaceswffile
'作 用：解析动画路径
'参 数：constr ------ 要替换的字符串
'参 数: tisturl------ 当前网页地址
'==================================================
function replaceswffile(constr,tisturl)
if constr="$false$" or constr="" or tisturl="" or tisturl="$false$" then
replaceswffile=constr
exit function
end if
dim tempstr,tempstr2,tempstr3,re,matches,match,tempi,temparray,temparray2

set re = new regexp
re.ignorecase = true
re.global = true
re.pattern ="<object.+?[^\>]>"
set matches =re.execute(constr)
for each match in matches
if tempstr<>"" then
tempstr=tempstr & "$array$" & match.value
else
tempstr=match.value
end if
next
if tempstr<>"" then
temparray=split(tempstr,"$array$")
tempstr=""
for tempi=0 to ubound(temparray)
re.pattern ="value\s*=\s*.+?\.swf"
set matches =re.execute(temparray(tempi))
for each match in matches
if tempstr<>"" then
tempstr=tempstr & "$array$" & match.value
else
tempstr=match.value
end if
next
next
end if
if tempstr<>"" then
re.pattern ="value\s*=\s*"
tempstr=re.replace(tempstr,"")
end if
if tempstr="" or isnull(tempstr)=true then
replaceswffile=constr
exit function
end if
tempstr=replace(tempstr,"""","")
tempstr=replace(tempstr,"'","")
tempstr=replace(tempstr," ","")

set matches=nothing
set re=nothing

'去掉重复文件开始
temparray=split(tempstr,"$array$")
tempstr=""
for tempi=0 to ubound(temparray)
if instr(lcase(tempstr),lcase(temparray(tempi)))<1 then
tempstr=tempstr & "$array$" & temparray(tempi)
end if
next
tempstr=right(tempstr,len(tempstr)-7)
temparray=split(tempstr,"$array$")
'去掉重复文件结束

'转换相对地址开始
tempstr=""
for tempi=0 to ubound(temparray)
tempstr=tempstr & "$array$" & definiteurl(temparray(tempi),tisturl)
next
tempstr=right(tempstr,len(tempstr)-7)
tempstr=replace(tempstr,chr(0),"")
temparray2=split(tempstr,"$array$")
tempstr=""
'转换相对地址结束

'替换
set re = new regexp
re.ignorecase = true
re.global = true
for tempi=0 to ubound(temparray2)
remotefileurl=temparray2(tempi)
re.pattern =temparray(tempi)
constr=re.replace(constr,remotefileurl)
next
set re=nothing
replaceswffile=constr
end function

'==================================================
'过程名：saveremotefile
'作 用：保存远程的文件到本地
'参 数：localfilename ------ 本地文件名
'参 数：remotefileurl ------ 远程文件url
'参 数：referer ------ 远程调用文件（对付防采集的，用内容页地址，没有防的留空）
'==================================================
function saveremotefile(localfilename,remotefileurl,referer)
saveremotefile=true
dim ads,retrieval,getremotedata
set retrieval = server.createobject("microsoft.xmlhttp")
with retrieval
.open "get", remotefileurl, false, "", ""
if referer<>"" then .setrequestheader "referer",referer
.send
if .readystate<>4 then
saveremotefile=false
exit function
end if
getremotedata = .responsebody
end with
set retrieval = nothing
set ads = server.createobject("adodb.stream")
with ads
.type = 1
.open
.write getremotedata
.savetofile server.mappath(localfilename),2
.cancel()
.close()
end with
set ads=nothing
end function

'==================================================
'函数名：getpaing
'作 用：获取分页
'==================================================
function getpaing(byval constr,startstr,overstr,inclul,inclur)
if constr="$false$" or constr="" or startstr="" or overstr="" or isnull(constr)=true or isnull(startstr)=true or isnull(overstr)=true then
getpaing="$false$"
exit function
end if

dim start,over,contemp,tempstr
tempstr=lcase(constr)
startstr=lcase(startstr)
overstr=lcase(overstr)
over=instr(1,tempstr,overstr)
if over<=0 then
getpaing="$false$"
exit function
else
if inclur=true then
over=over+len(overstr)
end if
end if
tempstr=mid(tempstr,1,over)
start=instrrev(tempstr,startstr)
if inclul=false then
start=start+len(startstr)
end if

if start<=0 or start>=over then
getpaing="$false$"
exit function
end if
contemp=mid(constr,start,over-start)

contemp=trim(contemp)
'contemp=replace(contemp," ","")
contemp=replace(contemp,",","")
contemp=replace(contemp,"'","")
contemp=replace(contemp,"""","")
contemp=replace(contemp,">","")
contemp=replace(contemp,"<","")
contemp=replace(contemp," ;","")
getpaing=contemp
end function

'*************************************************
'函数名：gottopic
'作 用：截字符串，汉字一个算两个字符，英文算一个字符
'参 数：str ----原字符串
' strlen ----截取长度
'返回值：截取后的字符串
'*************************************************
function gottopic(str,strlen)
if str="" then
gottopic=""
exit function
end if
dim l,t,c, i
str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")
l=len(str)
t=0
for i=1 to l
c=abs(asc(mid(str,i,1)))
if c>255 then
t=t+2
else
t=t+1
end if
if t>=strlen then
gottopic=left(str,i) & "…"
exit for
else
gottopic=str
end if
next
gottopic=replace(replace(replace(replace(gottopic," "," "),chr(34),"""),">",">"),"<","<;")
end function

'***********************************************
'函数名：joinchar
'作 用：向地址中加入 ? 或 &
'参 数：strurl ----网址
'返回值：加了 ? 或 & 的网址
'***********************************************
function joinchar(strurl)
if strurl="" then
joinchar=""
exit function
end if
if instr(strurl,"?")<len(strurl) then
if instr(strurl,"?")>1 then
if instr(strurl,"&")<len(strurl) then
joinchar=strurl & "&"
else
joinchar=strurl
end if
else
joinchar=strurl & "?"
end if
else
joinchar=strurl
end if
end function


'**************************************************
'函数名：createkeyword
'作 用：由给定的字符串生成关键字
'参 数：constr---要生成关键字的原字符串
'返回值：生成的关键字
'**************************************************
function createkeyword(byval constr,num)
if constr="" or isnull(constr)=true or constr="$false$" then
createkeyword="$false$"
exit function
end if
if num="" or isnumeric(num)=false then
num=2
end if
constr=replace(constr,chr(32),"")
constr=replace(constr,chr(9),"")
constr=replace(constr," ","")
constr=replace(constr," ","")
constr=replace(constr,"(","")
constr=replace(constr,")","")
constr=replace(constr,"<","")
constr=replace(constr,">","")
constr=replace(constr,"""","")
constr=replace(constr,"?","")
constr=replace(constr,"*","")
constr=replace(constr,"","")
constr=replace(constr,",","")
constr=replace(constr,".","")
constr=replace(constr,"/","")
constr=replace(constr,"\","")
constr=replace(constr,"-","")
constr=replace(constr,"@","")
constr=replace(constr,"#","")
constr=replace(constr,"$","")
constr=replace(constr,"%","")
constr=replace(constr,"&","")
constr=replace(constr,"+","")
constr=replace(constr,":","")
constr=replace(constr,"：","")
constr=replace(constr,"‘","")
constr=replace(constr,"“","")
constr=replace(constr,"”","")
dim i,constrtemp
for i=1 to len(constr)
constrtemp=constrtemp & "" & mid(constr,i,num)
next
if len(constrtemp)<254 then
constrtemp=constrtemp & ""
else
constrtemp=left(constrtemp,254) & ""
end if
createkeyword=constrtemp
end function

'==================================================
'函数名：checkurl
'作 用：检查url
'参 数：strurl ------ 要检查url
'==================================================
function checkurl(strurl)
dim re
set re=new regexp
re.ignorecase =true
re.global=true
re.pattern="http://([\w-]+\.)+[\w-]+(/[\w-./?%&=]*)?"
if re.test(strurl)=true then
checkurl=strurl
else
checkurl="$false$"
end if
set rs=nothing
end function

'==================================================
'函数名：scripthtml
'作 用：过滤html标记
'参 数：constr ------ 要过滤的字符串
'==================================================
function scripthtml(byval constr,tagname,ftype)
dim re
set re=new regexp
re.ignorecase =true
re.global=true
select case ftype
case 1
re.pattern="<" & tagname & "([^>])*>"
constr=re.replace(constr,"")
case 2
re.pattern="<" & tagname & "([^>])*>.*?</" & tagname & "([^>])*>"
constr=re.replace(constr,"")
case 3
re.pattern="<" & tagname & "([^>])*>"
constr=re.replace(constr,"")
re.pattern="</" & tagname & "([^>])*>"
constr=re.replace(constr,"")
end select
scripthtml=constr
set re=nothing
end function

'==================================================
'函数名：removehtml
'作 用：完全去除html标记
'参 数：strhtml ------ 要过滤的字符串
'==================================================
function removehtml(strhtml)
dim objregexp, match, matches
set objregexp = new regexp

objregexp.ignorecase = true
objregexp.global = true
'取闭合的<>
objregexp.pattern = "<.+?>"
'进行匹配
set matches = objregexp.execute(strhtml)

' 遍历匹配集合，并替换掉匹配的项目
for each match in matches
strhtml=replace(strhtml,match.value,"")
next
removehtml=strhtml
set objregexp = nothing
end function

'==================================================
'函数名：checkdir
'作 用：检查文件夹是否存在
'参 数：folderpath ------ 文件夹路径
'==================================================
function checkdir(byval folderpath)
dim fso
set fso = server.createobject("scripting.filesystemobject")
if fso.folderexists(server.mappath(folderpath)) then
'存在
checkdir = true
else
'不存在
checkdir = false
end if
set fso = nothing
end function

'==================================================
'函数名：makenewsdir
'作 用：创建文件夹
'参 数：foldername ------ 文件夹名
'==================================================
function makenewsdir(byval foldername)
dim fso
set fso = server.createobject("scri" & "pti" & "ng.fil" & "esyst" & "emob" & "ject")
fso.createfolder(server.mappath(foldername))
if fso.folderexists(server.mappath(foldername)) then
makenewsdir = true
else
makenewsdir = false
end if
set fso = nothing
end function

'==================================================
'函数名：deldir
'作 用：创建文件夹
'参 数：foldername ------ 文件夹名
'==================================================
function deldir(byval foldername)
dim fso
set fso = server.createobject("scri" & "pti" & "ng.fil" & "esyst" & "emob" & "ject")
if fso.folderexists(server.mappath(foldername)) then '判断文件夹是否存在
fso.deletefolder (server.mappath(foldername)) '删除文件夹
end if
set fso = nothing
end function

'**************************************************
'函数名：isobjinstalled
'作 用：检查组件是否已经安装
'参 数：strclassstring ----组件名
'返回值：true ----已经安装
' false ----没有安装
'**************************************************
function isobjinstalled(strclassstring)
isobjinstalled = false
err = 0
dim xtestobj
set xtestobj = server.createobject(strclassstring)
if 0 = err then isobjinstalled = true
set xtestobj = nothing
err = 0
end function

'**************************************************
'函数名：strlength
'作 用：求字符串长度。汉字算两个字符，英文算一个字符。
'参 数：str ----要求长度的字符串
'返回值：字符串长度
'**************************************************
function strlength(str)
on error resume next
dim winnt_chinese
winnt_chinese = (len("中国")=2)
if winnt_chinese then
dim l,t,c
dim i
l=len(str)
t=l
for i=1 to l
c=asc(mid(str,i,1))
if c<0 then c=c+65536
if c>255 then
t=t+1
end if
next
strlength=t
else
strlength=len(str)
end if
if err.number<>0 then err.clear
end function


'****************************************************
'函数名：createmultifolder
'作 用：创建多级目录，可以创建不存在的根目录
'参 数：要创建的目录名称，可以是多级
'返回逻辑值：true成功，false失败
'创建目录的根目录从当前目录开始
'****************************************************
function createmultifolder(byval cfolder)
dim objfso,phcreatefolder,createfolderarray,createfolder
dim i,ii,createfoldersub,phcreatefoldersub,blinfo
blinfo = false
createfolder = cfolder
on error resume next
set objfso = server.createobject("scri" & "pti" & "ng.fil" & "esyst" & "emob" & "ject")
if err then
err.clear()
exit function
end if
createfolder = replace(createfolder,"\","/")
if left(createfolder,1)="/" then
'createfolder = right(createfolder,len(createfolder)-1)
end if
if right(createfolder,1)="/" then
createfolder = left(createfolder,len(createfolder)-1)
end if
createfolderarray = split(createfolder,"/")
for i = 0 to ubound(createfolderarray)
createfoldersub = ""
for ii = 0 to i
createfoldersub = createfoldersub & createfolderarray(ii) & "/"
next
phcreatefoldersub = server.mappath(createfoldersub)

'response.write phcreatefoldersub&"<br>"

if not objfso.folderexists(phcreatefoldersub) then
objfso.createfolder(phcreatefoldersub)
end if
next
if err then
err.clear()
else
blinfo = true
end if
set objfso=nothing
createmultifolder = blinfo
end function

'**************************************************
'函数名：fsofileread
'作 用：使用fso读取文件内容的函数
'参 数：filename ----文件名称
'返回值：文件内容
'**************************************************
function fsofileread(filename)
dim objfso,objcountfile,filetempdata
set objfso = server.createobject("scripting.filesystemobject")
set objcountfile = objfso.opentextfile(server.mappath(filename),1,true)
fsofileread = objcountfile.readall
objcountfile.close
set objcountfile=nothing
set objfso = nothing
end function

'**************************************************
'函数名：fsolinedit
'作 用：使用fso读取文件某一行的函数
'参 数：filename ----文件名称
' linenum ----行数
'返回值：文件该行内容
'**************************************************
function fsolinedit(filename,linenum)
if linenum < 1 then exit function
dim fso,f,temparray,tempcnt
set fso = server.createobject("scripting.filesystemobject")
if not fso.fileexists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.atendofstream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
if linenum>ubound(temparray)+1 then
exit function
else
fsolinedit = temparray(linenum-1)
end if
end if
end function

'**************************************************
'函数名：fsolinewrite
'作 用：使用fso写文件某一行的函数
'参 数：filename ----文件名称
' linenum ----行数
' linecontent ----内容
'返回值：无
'**************************************************
function fsolinewrite(filename,linenum,linecontent)
if linenum < 1 then exit function
dim fso,f,temparray,tempcnt
set fso = server.createobject("scripting.filesystemobject")
if not fso.fileexists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.atendofstream then
tempcnt = f.readall
f.close
temparray = split(tempcnt,chr(13)&chr(10))
if linenum>ubound(temparray)+1 then
exit function
else
temparray(linenum-1) = linecontent
end if
tempcnt = join(temparray,chr(13)&chr(10))
set f = fso.createtextfile(server.mappath(filename),true)
f.write tempcnt
end if
f.close
set f = nothing
end function

'**************************************************
'函数名：htmlmake
'作 用：使用fso创建文件
'参 数：htmlfolder ----路径
' htmlfilename ----文件名
' htmlcontent ----内容
'**************************************************
function htmlmake(htmlfolder,htmlfilename,htmlcontent)
on error resume next
dim filepath,fso,fout
filepath = htmlfolder&"/"&htmlfilename
set fso = server.createobject("scripting.filesystemobject")
if fso.folderexists(htmlfolder) then
else
createmultifolder(htmlfolder)
&, ;nbs, p; end if
set fout = fso.createtextfile(server.mappath(filepath),true)
fout.writeline htmlcontent
fout.close
set fso=nothing
set fso = server.createobject("scripting.filesystemobject")
if fso.fileexists(server.mappath(filepath)) then
response.write "文件<font color=red>"&htmlfilename&"</font>已生成!<br>"
else
'response.write server.mappath(filepath)
response.write "文件<font color=red>"&htmlfilename&"</font>未生成!<br>"
end if
set fso = nothing
end function

'**************************************************
'函数名：htmldel
'作 用：使用fso删除文件
'参 数：htmlfolder ----路径
' htmlfilename ----文件名
'**************************************************
sub htmldel(htmlfolder,htmlfilename)
dim filepath,fso
filepath = htmlfolder&"/"&htmlfilename
set fso = createobject("scripting.filesystemobject")
fso.deletefile(server.mappath(filepath))
set fso = nothing
set fso = server.createobject("scripting.filesystemobject")
if fso.fileexists(server.mappath(filepath)) then
response.write "文件<font color=red>"&htmlfilename&"</font>未删除!<br>"
else
'response.write server.mappath(filepath)
response.write "文件<font color=red>"&htmlfilename&"</font>已删除!<br>"
end if
set fso = nothing
end sub

'=================================================
'过程名：htmlencode
'作 用：过滤html格式
'参 数：fstring ----转换内容
'=================================================
function htmlencode(byval fstring)
if isnull(fstring)=false or fstring<>"" or fstring<>"$false$" then
fstring = replace(fstring, ">", ">")
fstring = replace(fstring, "<", "<")
fstring = replace(fstring, chr(32), " ")
fstring = replace(fstring, chr(9), " ")
fstring = replace(fstring, chr(34), """)
fstring = replace(fstring, chr(39), "'")
fstring = replace(fstring, chr(13), "")
fstring = replace(fstring, " ", " ")
fstring = replace(fstring, chr(10) & chr(10), "</p><p>")
fstring = replace(fstring, chr(10), "<br /> ")
htmlencode = fstring
else
htmlencode = "$false$"
end if
end function

'=================================================
'过程名：unhtmlencode
'作 用：还原html格式
'参 数：fstring ----转换内容
'=================================================
function unhtmlencode(byval fstring)
if isnull(fstring)=false or fstring<>"" or fstring<>"$false$" then
fstring = replace(fstring, ">", ">")
fstring = replace(fstring, "<", "<")
fstring = replace(fstring, " ", chr(32))
fstring = replace(fstring, """, chr(34))
fstring = replace(fstring, "'", chr(39))
fstring = replace(fstring, "", chr(13))
fstring = replace(fstring, " ", " ")
fstring = replace(fstring, "</p><p>" , chr(10) & chr(10))
fstring = replace(fstring, "<br> ", chr(10))
unhtmlencode = fstring
else
unhtmlencode = "$false$"
end if
end function

function unhtmllist(content)
unhtmllist=content
if content <> "" then
unhtmllist=replace(unhtmllist,"'","";")
unhtmllist=replace(unhtmllist,chr(10),"")
unhtmllist=replace(unhtmllist,chr(13),"<br>")
end if
end function

function unhtmllists(content)
unhtmllists=content
if content <> "" then
unhtmllists=replace(unhtmllists,"""",""")
unhtmllists=replace(unhtmllists,"'",""")
unhtmllists=replace(unhtmllists,chr(10),"")
unhtmllists=replace(unhtmllists,chr(13),"<br>")
end if
end function

function htmllists(content)
htmllists=content
if content <> "" then
htmllists=replace(htmllists,"‘'","""")
htmllists=replace(htmllists,""","'")
htmllists=replace(htmllists,"<br>",chr(13)&chr(10))
end if
end function

function uhtmllists(content)
uhtmllists=content
if content <> "" then
uhtmllists=replace(uhtmllists,"""","‘'")
uhtmllists=replace(uhtmllists,"'","";")
uhtmllists=replace(uhtmllists,chr(10),"")
uhtmllists=replace(uhtmllists,chr(13),"<br>")
end if
end function

'=================================================
'过程： sleep
'功能： 程序在此晢停几秒
'参数： iseconds 要暂停的秒数
'=================================================
sub sleep(iseconds)
response.write "<font color=blue>开始暂停 "&iseconds&" 秒</font><br>"
dim t:t=timer()
while(timer()<t+iseconds)
'do nothing
wend
response.write "<font color=blue>暂停 "&iseconds&" 秒结束</font><br>"
end sub

'==================================================
'函数名：myarray
'作 用：提取标签，以分隔
'参 数：constr ------提取地址的原字符
'==================================================
function myarray(byval constr)
set objregexp = new regexp
objregexp.ignorecase = true
objregexp.global = true
objregexp.pattern = "({).+?(})"
set matches =objregexp.execute(constr)
for each match in matches
tempstr=tempstr & "" & match.value
next
set matches=nothing

tempstr=right(tempstr,len(tempstr)-1)
objregexp.pattern ="{"
tempstr=objregexp.replace(tempstr,"")
objregexp.pattern ="}"
tempstr=objregexp.replace(tempstr,"")
set objregexp=nothing
set matches=nothing

tempstr=replace(tempstr,"$","")

if tempstr="" then
myarray="在代码中没有可提取的东西"
else
myarray=tempstr
end if
end function

'==================================================
'函数名：randm
'作 用：产生6位随机数
'==================================================
function randm
randomize
randm=int((900000*rnd)+100000)
end function
%>