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

<%
'==================================================
'过程名：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