创力采集程序用到的函数 推荐

'==================================================
'过程名：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,"&nbsp;"," ")
       fString = Replace(fString,"&quot;","")
       fString = Replace(fString,"&#39;","")
       fString = replace(fString, ">", "")
       fString = replace(fString, "<", "")
       fString = Replace(fString, CHR(9), " ")'&nbsp;
       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,"&#106avascript")
re.Pattern="(jscript:)"
t=re.Replace(t,"&#106script:")
re.Pattern="(js:)"
t=re.Replace(t,"&#106s:")
're.Pattern="(value)"
't=re.Replace(t,"&#118alue")
re.Pattern="(about:)"
t=re.Replace(t,"about&#58")
re.Pattern="(file:)"
t=re.Replace(t,"file&#58")
re.Pattern="(document.cookie)"
t=re.Replace(t,"documents&#46cookie")
re.Pattern="(vbscript:)"
t=re.Replace(t,"&#118bscript:")
re.Pattern="(vbs:)"
t=re.Replace(t,"&#118bs:")
re.Pattern="(on(mouse|exit|error|click|key))"
t=re.Replace(t,"&#111n$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,"&nbsp;","")
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,"&nbsp;","")
   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
%>