欢迎您访问程序员文章站本站旨在为大家提供分享程序员计算机编程知识!
您现在的位置是: 首页  >  IT编程

创力采集程序用到的函数 推荐第1/3页

程序员文章站 2022-06-15 14:24:43
复制代码 代码如下:<% '================================================== '过程名: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