创力采集程序用到的函数 推荐第1/3页
程序员文章站
2022-07-02 08:39:59
复制代码 代码如下:<% '================================================== '过程名:admin_showcha...
复制代码 代码如下:
<%
'==================================================
'过程名:admin_showchannel_name
'作 用:显示频道名称
'参 数:channelid ------频道id
'==================================================
sub admin_showchannel_name(channelid)
dim sqlc,rsc,tempstr
channelid=clng(channelid)
sqlc ="select top 1 channelname from cl_channel where channelid=" & channelid
set rsc=server.createobject("adodb.recordset")
openconn : rsc.open sqlc,conn,1,1
if rsc.eof and rsc.bof then
tempstr="无指定频道"
else
tempstr=rsc("channelname")
end if
rsc.close : set rsc=nothing
response.write tempstr
end sub
'==================================================
'过程名:admin_showchannel_option
'作 用:显示频道选项
'参 数:channelid ------频道id
'==================================================
sub admin_showchannel_option(channelid)
dim sqlc,rsc,channelname,tempstr
channelid=clng(channelid)
sqlc ="select channelid,channelname from cl_channel where channelid>0 and channelid<>6 and
channeltype<2 and moduleid=1"
set rsc=server.createobject("adodb.recordset")
openconn : rsc.open sqlc,conn,1,1
tempstr="<option value=""0"">请选择频道</option>"
if rsc.eof and rsc.bof then
tempstr=tempstr & "<option value=""0"">请添加频道</option>"
else
do while not rsc.eof
tempstr=tempstr & "<option value=" & """" & rsc("channelid") & """" & ""
if channelid=rsc("channelid") then
tempstr=tempstr & " selected"
end if
tempstr=tempstr & ">" & rsc("channelname")
tempstr=tempstr & "</option>"
rsc.movenext
loop
end if
rsc.close
set rsc=nothing
response.write tempstr
end sub
'==================================================
'过程名:admin_showclass_name
'作 用:显示栏目名称
'参 数:channelid ------频道id
'参 数:classid ------栏目id
'==================================================
sub admin_showclass_name(channelid,classid)
dim sqlc,rsc,tempstr
channelid=clng(channelid)
classid=clng(classid)
sqlc ="select top 1 classname from cl_class where channelid=" & channelid & " and classid=" & classid
set rsc=server.createobject("adodb.recordset")
openconn : rsc.open sqlc,conn,1,1
if rsc.eof and rsc.bof then
tempstr="无指定栏目"
else
tempstr=rsc("classname")
end if
rsc.close : set rsc=nothing
response.write tempstr
end sub
'==================================================
'过程名:admin_showspecial_name
'作 用:显示专题名称
'参 数:channelid ------频道id
'参 数:specialid ------专题id
'==================================================
sub admin_showspecial_name(channelid,specialid)
dim sqlc,rsc,tempstr
channelid=clng(channelid)
specialid=clng(specialid)
sqlc ="select top 1 specialname from cl_special where specialid=" & specialid
set rsc=server.createobject("adodb.recordset")
openconn : rsc.open sqlc,conn,1,1
if rsc.eof and rsc.bof then
tempstr="无指定专题"
else
tempstr=rsc("specialname")
end if
rsc.close : set rsc=nothing
response.write tempstr
end sub
'==================================================
'过程名:admin_showitem_name
'作 用:显示项目名称
'参 数:itemid ------项目id
'==================================================
sub admin_showitem_name(itemid)
dim sqlc,rsc,tempstr
itemid=clng(itemid)
sqlc ="select top 1 itemname from item where itemid=" & itemid
set rsc=server.createobject("adodb.recordset")
rsc.open sqlc,connitem,1,1
if rsc.eof and rsc.bof then
tempstr="无指定项目"
else
tempstr=rsc("itemname")
end if
rsc.close : set rsc=nothing
response.write tempstr
end sub
'==================================================
'过程名:admin_showitem_option
'作 用:显示项目选项
'参 数:itemid ------项目id
'==================================================
sub admin_showitem_option(itemid)
dim sqli,rsi,tempstr
itemid=clng(itemid)
sqli ="select itemid,itemname from item order by itemid desc"
set rsi=server.createobject("adodb.recordset")
rsi.open sqli,connitem,1,1
tempstr="<select name=""itemid"" id=""itemid"">"
if rsi.eof and rsi.bof then
tempstr=tempstr & "<option value=""0"">请添加项目</option>"
else
tempstr=tempstr & "<option value=""0"">请选择项目</option>"
do while not rsi.eof
tempstr=tempstr & "<option value=" & """" & rsi("itemid") & """" & ""
if itemid=rsi("itemid") then
tempstr=tempstr & " selected"
end if
tempstr=tempstr & ">" & rsi("itemname")
tempstr=tempstr & "</option>"
rsi.movenext
loop
end if
rsi.close
set rsi=nothing
tempstr=tempstr & "</select>"
response.write tempstr
end sub
'==================================================
'函数名: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
on error resume next
set http=server.createobject("msxml2.xmlhttp")
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")
set http=nothing
if err.number<>0 then err.clear
end function
'==================================================
'函数名:bytestobstr
'作 用:将获取的源码转换为中文
'参 数:body ------要转换的变量
'参 数:cset ------要转换的类型
'==================================================
function bytestobstr(body,cset)
dim objstream
on error resume next
set objstream = server.createobject("adodb." & "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
on error resume next
set xmlhttp = createobject("msxml2.xmlhttp")
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
1
上一篇: 喝什么不会胖,喝这些想胖都难