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

'==================================================
'过程名：saveremotefile
'作  用：保存远程的文件到本地
'参  数：localfilename ------ 本地文件名
'参  数：remotefileurl ------ 远程文件url
'==================================================
function saveremotefile(localfilename,remotefileurl)
    saveremotefile=true
    dim ads,retrieval,getremotedata
    on error resume next
    set retrieval = server.createobject("microsoft.xmlhttp")
    with retrieval
        .open "get", remotefileurl, false, "", ""
        .send
        if .readystate<>4 then
            saveremotefile=false
            exit function
        end if
        getremotedata = .responsebody
    end with
    set retrieval = nothing
    set ads = server.createobject("adodb." & "str" & "eam")
    with ads
        .type = 1
        .open
        .write getremotedata
        .savetofile server.mappath(localfilename),2
        .cancel()
        .close()
    end with
    set ads=nothing
end function

'==================================================
'函数名：htmlencode
'作  用：标题过滤
'参  数：fstring ------字符串
'==================================================
function htmlencode(fstring)
   if isnull(fstring)=false or fstring<>"" or fstring<>"$false$" then
       fstring=cl.nohtml(fstring)
       fstring=filterjs(fstring)
       fstring = replace(fstring," "," ")
       fstring = replace(fstring,""","")
       fstring = replace(fstring,"'","")
       fstring = replace(fstring, ">", "")
       fstring = replace(fstring, "<", "")
       fstring = replace(fstring, chr(9), " ")' 
       fstring = replace(fstring, chr(10), "")
       fstring = replace(fstring, chr(13), "")
       fstring = replace(fstring, chr(34), "")
       fstring = replace(fstring, chr(32), " ")'space
       fstring = replace(fstring, chr(39), "")
       fstring = replace(fstring, chr(10) & chr(10),"")
       fstring = replace(fstring, chr(10)&chr(13), "")
       fstring=trim(fstring)
       htmlencode=fstring
   else
       htmlencode="$false$"
   end if
end function

function filterjs(v)
if not isnull(v) then
dim t
dim re
dim recontent
set re=new regexp
re.ignorecase =true
re.global=true
re.pattern="(javascript)"
t=re.replace(v,"javascript")
re.pattern="(jscript:)"
t=re.replace(t,"jscript:")
re.pattern="(js:)"
t=re.replace(t,"js:")
're.pattern="(value)"
't=re.replace(t,"value")
re.pattern="(about:)"
t=re.replace(t,"about:")
re.pattern="(file:)"
t=re.replace(t,"file:")
re.pattern="(document.cookie)"
t=re.replace(t,"documents.cookie")
re.pattern="(vbscript:)"
t=re.replace(t,"vbscript:")
re.pattern="(vbs:)"
t=re.replace(t,"vbs:")
re.pattern="(on(mouse|exit|error|click|key))"
t=re.replace(t,"on$2")
're.pattern="(&#)"
't=re.replace(t,"＆#")
filterjs=t
set re=nothing
end if
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

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

function checkdir(byval folderpath)
    dim fso
    set fso = server.createobject(trim(cl.web_info(13)))
    if fso.folderexists(server.mappath(folderpath)) then
    '存在
        checkdir = true
    else
    '不存在
        checkdir = false
    end if
    set fso = nothing
end function
function makenewsdir(byval foldername)
    dim fso
    set fso = server.createobject(trim(cl.web_info(13)))
        fso.createfolder(server.mappath(foldername))
        if fso.folderexists(server.mappath(foldername)) then
           makenewsdir = true
        else
           makenewsdir = false
        end if
    set fso = nothing
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

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

sub setchannel()
dim arr_channel,i_channel,i_class,i_special,tmpdepth,i,arrshowline(20)
dim classid,classname,specialid,specialname
set rs=server.createobject("adodb.recordset")
sql = "select channelid from cl_channel where channelid>=1 and channelid<>6 and channeltype<2 and 
moduleid=1"
openconn : rs.open sql,conn,1,1
if not rs.eof then
   arr_channel=rs.getrows(-1)
end if
rs.close
set rs=nothing

if isarray(arr_channel)= true then
   i_class=0
   i_special=0
   for i=0 to ubound(arrshowline)
      arrshowline(i)=false
   next
%>
<script language = "javascript">
var count_class;
var count_special;
arr_class = new array();
arr_special= new array();
<%
   for i_channel=0 to ubound(arr_channel,2)
      set rs=server.createobject("adodb.recordset")
      sql = "select * from cl_class where channelid=" & arr_channel(0,i_channel) & " order by 
rootid,orderid"
      openconn : rs.open sql,conn,1,1
%>
arr_class[<%=i_class%>] = new array("<%=arr_channel(0,i_channel)%>","0","请选择栏目");
<%
      i_class=i_class+1
      if not rs.eof then
         do while not rs.eof
            classname="" 
            tmpdepth=rs("depth")
            if rs("nextid")>0 then
        arrshowline(tmpdepth)=true
        else
        arrshowline(tmpdepth)=false
        end if
            if rs("child")>0 or rs("isouter")=1 then
               classid=0
            else
               classid=rs("classid")
            end if
            if tmpdepth>0 then
           for i=1 to tmpdepth
              if i=tmpdepth then
                   if rs("nextid")>0 then
                classname=classname & " ├ "
             else
            classname=classname & "  └ "
             end if
          else
             if arrshowline(i)=true then
                classname=classname & "│"
             else
            classname=classname & "  "
             end if
          end if
           next
        end if
        classname=classname & rs("classname")
        if rs("isouter")=1 then
        classname=classname & "(外)"
         end if
%>
arr_class[<%=i_class%>] = new array("<%=arr_channel(0,i_channel)%>","<%=classid%>","<%=classname%>");
<%
            i_class = i_class + 1
            rs.movenext
         loop
      end if
      rs.close
      set rs=nothing

      set rs=server.createobject("adodb.recordset")
      sql = "select specialid,specialname from cl_special where channelid=" & arr_channel(0,i_channel) & " 
order by specialid"
      openconn : rs.open sql,conn,1,1
%>
arr_special[<%=i_special%>] = new array("<%=arr_channel(0,i_channel)%>","0","不属于任何专题");
<%
      i_special=i_special+1
      if not rs.eof then
         do while not rs.eof
%>
arr_special[<%=i_special%>] = new array("<%=arr_channel(0,i_channel)%>","<%=rs("specialid")%>","<%=rs
("specialname")%>");
<% 
            i_special=i_special + 1
            rs.movenext
         loop
      end if
      rs.close
      set rs=nothing  
   next
%>
count_class=<%=i_class%>;
count_special=<%=i_special%>;

function changelocation(locationid)
    {
    document.myform.classid.length = 0; 
    document.myform.specialid.length = 0;
    var locationid=locationid;
    var i;
    for (i=0;i < count_class; i++)
        {
            if (arr_class[i][0] == locationid)
            { 
                document.myform.classid.options[document.myform.classid.length] = new option(arr_class[i]
[2], arr_class[i][1]);
            }        
        }
    for (i=0;i < count_special; i++)
        {
            if (arr_special[i][0] == locationid)
            { 
                document.myform.specialid.options[document.myform.specialid.length] = new option
(arr_special[i][2], arr_special[i][1]);
            }        
        }
    }    
</script>
<%
end if
end sub

'==================================================
'过程名：getfilters
'作  用：提取过滤信息
'参  数：无
'==================================================
sub getfilters()
   sqlf ="select * from filters where flag=true and (publictf=true or itemid=" & itemid & ") order by 
filterid asc"
   set rsf=connitem.execute(sqlf)
   if rsf.eof and rsf.bof then
      arr_filters=""
   else
      arr_filters=rsf.getrows()
   end if
   rsf.close
   set rsf=nothing
end sub


'==================================================
'过程名：filters
'作  用：过滤
'==================================================
sub filters()
    if isarray(arr_filters)=false then
        exit sub
    end if

    for filteri=0 to ubound(arr_filters,2)
        filterstr=""
        if arr_filters(1,filteri)=itemid or arr_filters(10,filteri)=true then
            if arr_filters(3,filteri)=1 then'标题过滤
                if arr_filters(4,filteri)=1 then
                title=replace(title,arr_filters(5,filteri),arr_filters(8,filteri))
                elseif arr_filters(4,filteri)=2 then
                filterstr=getbody(title,arr_filters(6,filteri),arr_filters
(7,filteri),true,true)
                do while filterstr<>"$false$"
                    title=replace(title,filterstr,arr_filters(8,filteri))
                    filterstr=getbody(title,arr_filters(6,filteri),arr_filters
(7,filteri),true,true)
                loop
                end if
            elseif arr_filters(3,filteri)=2 then'正文过滤
                if arr_filters(4,filteri)=1 then
                    content=replace(content,arr_filters(5,filteri),arr_filters
(8,filteri))
                elseif arr_filters(4,filteri)=2 then
                    filterstr=getbody(content,arr_filters(6,filteri),arr_filters
(7,filteri),true,true)
                    do while filterstr<>"$false$"
                        content=replace(content,filterstr,arr_filters(8,filteri))
                        filterstr=getbody(content,arr_filters
(6,filteri),arr_filters(7,filteri),true,true)
                    loop
                end if
            end if
        end if
    next
end sub
%>