<%
'|-----------------------------------------------------------------------|
'|---------飞越软件信息采集器v1.0 for 动易网站管理系统2005/2006 ---------|
'|-------------------------- 作者:科技创造自由 --------------------------|
'|------------------ 飞越快乐家园  http://www.fy66.net/ -----------------|
'|--动易版主Top在本插件的编写过程中给予了大力支持,特此表示诚恳的感谢!----|
'|------ 本插件多处代码参考了SNA新闻采集系统for动易4.03,特此声明! -------|
'|----- 转载请保留版权信息,手下留情,留下的是对别人的尊重,谢谢! ----------|
'|-----------------------------------------------------------------------|
'==================================================
'过程名：ShowClassItem
'作  用：显示栏目名称
'参  数：ClassID ------栏目ID
'==================================================
Sub ShowClassItem(ClassID)   
   Dim SqlC,RsC   
   Sqlc ="Select top 1 ClassName from ArticleClass Where ClassID=" & ClassID   
   Set RsC=server.CreateObject("adodb.recordset")   
   RsC.Open SqlC,Conn,1,1   
   If RsC.Eof And RsC.Bof Then   
      Response.Write "无指定栏目"   
   Else   
      Response.Write RsC("ClassName")
   End if   
   RsC.Close   
   Set RsC=Nothing   
End Sub  

'==================================================
'过程名：ShowSpecialItem
'作  用：显示专题名称
'参  数：SpecialID ------专题ID
'==================================================
Sub ShowSpecialItem(SpecialID)   
   Dim Sqlc,Rsc   
   Sqlc ="select top 1 SpecialName from Special Where SpecialID=" & SpecialID   
   Set Rsc=server.CreateObject("adodb.recordset")   
   Rsc.open Sqlc,Conn,1,1   
   If Rsc.Eof and Rsc.Bof then   
      Response.write "无指定专题"   
   Else   
      Response.Write Rsc("SpecialName")
   End if   
   Rsc.Close   
   Set Rsc=Nothing   
End Sub  

'==================================================
'过程名：ShowItemName
'作  用：显示项目名称
'参  数：ItemID ------项目ID
'==================================================
Sub ShowItemName(ItemID)   
   Dim Sqlc,Rsc
   if ItemID=0 then
     Response.write "公用项目"
   Else
  	 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   
  	    Response.write "无指定项目"   
  	 Else   
  	    Response.Write Rsc("ItemName")
  	 End if   
  	 Rsc.Close   
  	 Set Rsc=Nothing   
   End if
End Sub  

'==================================================
'过程名：ShowItem_Option
'作  用：显示项目选项
'参  数：ItemID ------项目ID
'==================================================
Sub ShowItem_Option(ItemID)   
   Dim SqlI,RsI  
   SqlI ="select ItemID,ItemName from Item order by ItemID desc"   
   Set RsI=server.CreateObject("adodb.recordset")   
   RsI.Open SqlI,ConnItem,1,1
   Response.write "<select Name=""ItemID"" ID=""ItemID"">"   
   If RsI.Eof and RsI.Bof Then
      Response.write "<option value="""">请添加项目</option>"   
   Else   
      Response.write "<option value="""">请选择项目</option>"
      Do while not RsI.Eof   
         Response.Write "<option value=" & """" & RsI("ItemID") & """" & "" 
         If ItemID=RsI("ItemID") Then
            Response.Write " Selected"
         End If
         Response.Write ">" & RsI("ItemName")
         Response.Write "</option>"  
      RsI.Movenext   
      Loop   
   End if
   Response.write "<option value=""0"""
   if ItemID=0 then
       Response.Write " Selected"
   End if
   Response.write ">公用项目</option></select>"
   RsI.Close   
   Set RsI=Nothing   
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
   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 If
End Function

'==================================================
'函数名：BytesToBstr
'作  用：将获取的源码转换为中文
'参  数：Body ------要转换的变量
'参  数：Cset ------要转换的类型
'==================================================
Function BytesToBstr(Body,Cset)
   Dim Objstream
   Set Objstream = Server.CreateObject("adodb.stream")
   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      
    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 Start,Over
   Start = InStrB(1, ConStr, 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,ConStr,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
   ConStr=Replace(ConStr,"[","Kk51K2k1K5k2Dd21DdD32d1Hh2Hh32Hh23AED3DGSDGE")
   ConStr=Replace(ConStr,"]","TTTasdgsdg4555DGhDgTTddddgode02")
   StartStr=Replace(StartStr,"[","Kk51K2k1K5k2Dd21DdD32d1Hh2Hh32Hh23AED3DGSDGE")
   StartStr=Replace(StartStr,"]","TTTasdgsdg4555DGhDgTTddddgode02")
   OverStr=Replace(OverStr,"[","Kk51K2k1K5k2Dd21DdD32d1Hh2Hh32Hh23AED3DGSDGE")
   OverStr=Replace(OverStr,"]","TTTasdgsdg4555DGhDgTTddddgode02")
   Set objRegExp = New Regexp 
   objRegExp.IgnoreCase = True 
   objRegExp.Global = True
   objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"
   Set Matches =objRegExp.Execute(ConStr) 
   For Each Match in Matches
      If TempStr<>"" then 
         TempStr=TempStr & "$Array$" & Match.Value
      Else
         TempStr=Match.Value
      End if
   Next 
   Set Matches=nothing
   Set objRegExp=nothing
   If IncluL=False then
      TempStr=Replace(TempStr,StartStr,"")
   End if
   If IncluR=False then
      TempStr=Replace(TempStr,OverStr,"")
   End if
   TempStr=Replace(TempStr,"""","")
   TempStr=Replace(TempStr,"'","")
   If TempStr="" then
      GetArray="$False$"
   Else
      GetArray=TempStr
   End if
End Function


'==================================================
'函数名：DefiniteUrl
'作  用：将相对地址转换为绝对地址
'参  数：PrimitiveUrl ------要转换的相对地址
'参  数：ConsultUrl ------当前网页地址
'==================================================
Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
   Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
   If PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$False$" Then
      DefiniteUrl="$False$"
      Exit Function
   End If
   If Left(ConsultUrl,7)<>"HTTP://" And Left(ConsultUrl,7)<>"http://" Then
      ConsultUrl= "http://" & ConsultUrl
   End If
   ConsultUrl=Replace(ConsultUrl,"://",":\\")
   If Right(ConsultUrl,1)<>"/" Then
      If Instr(ConsultUrl,"/")>0 Then
         If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then   
         Else
            ConsultUrl=ConsultUrl & "/"
         End If
      Else
         ConsultUrl=ConsultUrl & "/"
      End If
   End If
   ConArray=Split(ConsultUrl,"/")
   If Left(PrimitiveUrl,7) = "http://" then
      DefiniteUrl=Replace(PrimitiveUrl,"://",":\\")
   ElseIf Left(PrimitiveUrl,1) = "/" Then
      DefiniteUrl=ConArray(0) & PrimitiveUrl
   ElseIf Left(PrimitiveUrl,2)="./" Then
      DefiniteUrl=ConArray(0) & Right(PrimitiveUrl,Len(PrimitiveUrl)-1)
   ElseIf Left(PrimitiveUrl,3)="../" then
      Do While Left(PrimitiveUrl,3)="../"
         PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
         Pi=Pi+1
      Loop            
      For Ci=0 to (Ubound(ConArray)-1-Pi)
         If DefiniteUrl<>"" Then
            DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
         Else
            DefiniteUrl=ConArray(Ci)
         End If
      Next
      DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl
   Else
      If Instr(PrimitiveUrl,"/")>0 Then
         PriArray=Split(PrimitiveUrl,"/")
         If Instr(PriArray(0),".")>0 Then
            If Right(PrimitiveUrl,1)="/" Then
               DefiniteUrl="http:\\" & PrimitiveUrl
            Else
               If Instr(PriArray(Ubound(PriArray)-1),".")>0 Then 
                  DefiniteUrl="http:\\" & PrimitiveUrl
               Else
                  DefiniteUrl="http:\\" & PrimitiveUrl & "/"
               End If
            End If      
         Else
            If Right(ConsultUrl,1)="/" Then   
               DefiniteUrl=ConsultUrl & PrimitiveUrl
            Else
               DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
            End If
         End If
      Else
         If Instr(PrimitiveUrl,".")>0 Then
            If Right(ConsultUrl,1)="/" Then
               If right(PrimitiveUrl,3)=".cn" or right(PrimitiveUrl,3)="com" or right(PrimitiveUrl,3)="net" or right(PrimitiveUrl,3)="org" Then
                  DefiniteUrl="http:\\" & PrimitiveUrl & "/"
               Else
                  DefiniteUrl=ConsultUrl & PrimitiveUrl
               End If
            Else
               If right(PrimitiveUrl,3)=".cn" or right(PrimitiveUrl,3)="com" or right(PrimitiveUrl,3)="net" or right(PrimitiveUrl,3)="org" Then
                  DefiniteUrl="http:\\" & PrimitiveUrl & "/"
               Else
                  DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl
               End If
            End If
         Else
            If Right(ConsultUrl,1)="/" Then
               DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"
            Else
               DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"
            End If         
         End If
      End If
   End If
   If Left(DefiniteUrl,1)="/" then
     DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
   End if
   If DefiniteUrl<>"" Then
      DefiniteUrl=Replace(DefiniteUrl,"//","/")
      DefiniteUrl=Replace(DefiniteUrl,":\\","://")
   Else
      DefiniteUrl="$False$"
   End If
End Function

'==================================================
'函数名：ReplaceSaveRemoteFile
'作  用：替换、保存远程文件
'参  数：ConStr ------ 要替换的字符串
'参  数：StarStr ----- 前导
'参  数：OverStr ----- 
'参  数：IncluL ------ 
'参  数：IncluR ------ 
'参  数：SaveTf ------ 是否保存文件，False不保存，True保存
'参  数：SaveFilePath- 保存文件夹
'参  数: TistUrl------ 当前网页地址
'==================================================
Function ReplaceSaveRemoteFile(ConStr,StartStr,OverStr,IncluL,IncluR,SaveTf,SaveFilePath,TistUrl)
   If IsObjInstalled("Scripting.FileSystemObject")=False then'没有安装组件
      SaveTf=False
   End if
   If ConStr="$False$" or ConStr="" Then
      ReplaceSaveRemoteFile="$False$"
      Exit Function
   End If
   Dim TempStr,TempStr2,ReF,Matches,Match,Tempi,TempArray,TempArray2,OverTypeArray

   Set ReF = New Regexp 
   ReF.IgnoreCase = True 
   ReF.Global = True
   ReF.Pattern = "("&StartStr&").+?("&OverStr&")"
   Set Matches =ReF.Execute(ConStr) 
   For Each Match in Matches
      If Instr(TempStr,Match.Value)=0 Then
         If TempStr<>"" then 
            TempStr=TempStr & "$Array$" & Match.Value
         Else
            TempStr=Match.Value
         End if
      End If
   Next 
   Set Matches=nothing
   Set ReF=nothing
   If TempStr="" or IsNull(TempStr)=True Then
      ReplaceSaveRemoteFile=ConStr
      Exit function
   End if
   If IncluL=False then
      TempStr=Replace(TempStr,StartStr,"")
   End if
   If IncluR=False then
      If Instr(OverStr,"|")>0 Then
         OverTypeArray=Split(OverStr,"|")
         For Tempi=0 To Ubound(OverTypeArray) 
            TempStr=Replace(TempStr,OverTypeArray(Tempi),"")
         Next
      Else
         TempStr=Replace(TempStr,OverStr,"")
      End If  
   End if
   TempStr=Replace(TempStr,"""","")
   TempStr=Replace(TempStr,"'","")

   Dim RemoteFile,RemoteFileurl,SaveFileName,SaveFileType,ArrSaveFileName,RanNum
   SaveFilePath="UploadFiles/" & year(now) & "-" & month(now)
   If Right(SaveFilePath,1)="/" then
      SaveFilePath=Left(SaveFilePath,Len(SaveFilePath)-1)
   End If
   If SaveTf=True then
      If CheckDir2(SaveFilePath)=False Then
         If MakeNewsDir2(SaveFilePath)=False Then
            SaveTf=False
         End If
      End If
   End If
 
   SaveFilePath=SaveFilePath & "/"

   '图片转换/保存
   TempArray=Split(TempStr,"$Array$")
   For Tempi=0 To Ubound(TempArray)
      RemoteFileurl=DefiniteUrl(TempArray(Tempi),TistUrl)
      If RemoteFileurl<>"$False$" And SaveTf=True Then'保存图片
	    ArrSaveFileName = Split(RemoteFileurl,".")
	    SaveFileType=ArrSaveFileName(Ubound(ArrSaveFileName))'文件类型
	    RanNum=Int(900*Rnd)+100
	    SaveFileName = SaveFilePath&year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&ranNum&"."&SaveFileType	               
	    Call SaveRemoteFile(SaveFileName,RemoteFileurl)
            ConStr=Replace(ConStr,TempArray(Tempi),SaveFileName)
      ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存图片
            SaveFileName=RemoteFileUrl
            ConStr=Replace(ConStr,TempArray(Tempi),SaveFileName)
      End If
      If RemoteFileUrl<>"$False$" Then
         If UploadFiles="" then
            UploadFiles=SaveFileName
         Else
            UploadFiles=UploadFiles & "|" & SaveFileName
         End if
      End If
   Next   
   ReplaceSaveRemoteFile=ConStr
End function


'==================================================
'过程名：SaveRemoteFile
'作  用：保存远程的文件到本地
'参  数：LocalFileName ------ 本地文件名
'参  数：RemoteFileUrl ------ 远程文件URL
'==================================================
sub SaveRemoteFile(LocalFileName,RemoteFileUrl)
	dim Ads,Retrieval,GetRemoteData
	
	''''
	Dim testfso,i,tt
	Set testfso= CreateObject("Scripting.FileSystemObject")
	''''
	
	Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
	With Retrieval
		.Open "Get", RemoteFileUrl, False, "", ""
		.setRequestHeader "Referer", RemoteFileUrl
		.Send
		GetRemoteData = .ResponseBody
	End With
	Set Retrieval = Nothing
	Set Ads = Server.CreateObject("Adodb.Stream")
	With Ads
		.Type = 1
		.Open
		
		.Write GetRemoteData
		
		.SaveToFile server.MapPath(LocalFileName),2
		.Cancel()
		.Close()
	End With

	Set Ads=nothing
end sub

'==================================================
'函数名：FpHtmlEnCode
'作  用：标题过滤
'参  数：fString ------字符串
'==================================================
Function FpHtmlEnCode(fString)
   If IsNull(fString)=False or fString<>"" Then
       'fString = Replace(fString, CHR(32), "")
       fString = Replace(fString, CHR(9), "")
       fString = Replace(fString, CHR(34), "")
       fString = Replace(fString, CHR(39), "")
       fString = Replace(fString, CHR(13), "")
       fString = Replace(fString, CHR(10), " ")
       fString=Trim(fString)
   End If
   fString=nohtml(fString)
   FpHtmlEnCode=fString
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,Erri
Over=InstrB(1,ConStr,OverStr,vbBinaryCompare)
If Over<=0 Then
   GetPaing="$False$"
   Exit Function
Else
   Over=Over+Lenb(OverStr)
End If

Start=Over-10
If Start<=0 Then
   GetPaing="$False$"
   Exit Function
End If

ConTemp=MidB(ConStr,Start,Over-Start)
Do While InstrB(1,ConTemp,StartStr,vbBinaryCompare)<=0
   Erri=Erri+1
   If Erri>50 then
      GetPaing="$False$"
      Exit Function
   End If 
   Start=Start-10
   if Start<=0 then
      GetPaing="$False$"
      Exit Do
      Exit Function
   Else
      ConTemp=MidB(ConStr,Start,Over-Start)
   End If
Loop

Start=InstrB(1,ConTemp,StartStr,vbBinaryCompare)
If IncluL=False Then
   Start=Start+LenB(StartStr)
End If
Over=InstrB(Start,ConTemp,OverStr,vbBinaryCompare)
If IncluR=True Then
   Over=Over+LenB(OverStr)
End If
If Start>=Over then
   GetPaing="$False$"
   Exit Function
End If
GetPaing=MidB(ConTemp,Start,Over-Start)
GetPaing=Trim(GetPaing)
GetPaing=Replace(GetPaing," ","")
GetPaing=Replace(GetPaing,",","")
GetPaing=Replace(GetPaing,"'","")
GetPaing=Replace(GetPaing,"""","")   
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 CheckDir2(byval FolderPath)
	dim fso
	folderpath=Server.MapPath(".")&"\"&folderpath
	Set fso = Server.CreateObject("Scripting.FileSystemObject")
	If fso.FolderExists(FolderPath) then
	'存在
		CheckDir2 = True
	Else
	'不存在
		CheckDir2 = False
	End if
	Set fso = nothing
End Function
Function MakeNewsDir2(byval foldername)
	dim fso
	Set fso = Server.CreateObject("Scripting.FileSystemObject")
        fso.CreateFolder(Server.MapPath(".") &"\" &foldername)
        If fso.FolderExists(Server.MapPath(".") &"\" &foldername) Then
           MakeNewsDir2 = True
        Else
           MakeNewsDir2 = False
        End If
	Set fso = nothing
End Function

function dvHTMLEncode(fString)
if not isnull(fString) then
    fString = replace(fString, ">", "&gt;")
    fString = replace(fString, "<", "&lt;")
    fString = Replace(fString, CHR(32), "&nbsp;")
    fString = Replace(fString, CHR(9), "&nbsp;")
    fString = Replace(fString, CHR(34), "&quot;")
    fString = Replace(fString, CHR(39), "&#39;")
    fString = Replace(fString, CHR(13), "")
    fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
    fString = Replace(fString, CHR(10), "<BR> ")
    dvHTMLEncode = fString
end if
end function

function dvHTMLEncode1(fString)
if not isnull(fString) then
    fString = replace(fString, ">", "&gt;")
    fString = replace(fString, "<", "&lt;")
    'fString = Replace(fString, CHR(32), "&nbsp;")
    'fString = Replace(fString, CHR(9), "&nbsp;")
    'fString = Replace(fString, CHR(34), "&quot;")
    'fString = Replace(fString, CHR(39), "&#39;")
    'fString = Replace(fString, CHR(13), "")
    'fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
    'fString = Replace(fString, CHR(10), "<BR> ")
    dvHTMLEncode1 = fString
end if
end function

function nohtml(str)
	dim re
	Set re=new RegExp
	re.IgnoreCase =true
	re.Global=True
	re.Pattern="(\<.*?\>)"
	str=re.replace(str,"")
	re.Pattern="(\<\/.*?\>)"
	str=re.replace(str,"")
	nohtml=str
end function


Sub ShowName(ShowType,ID)
if ID<>"" then
	dim rrs,rsql
	set rrs=server.createobject("adodb.recordset")
	if ShowType=1 then
		rsql="select * from PE_Channel where ChannelID="&ID&""
	Elseif ShowType=2 then
		rsql="select * from PE_Class where ClassID="&ID&""
	Elseif ShowType=3 then
		rsql="select * from PE_Special where SpecialID="&ID&""
	End if	
	rrs.open rsql,Conn,1,1
	if not(rrs.eof and rrs.bof) then
		if ShowType=1 then
			Response.Write rrs("ChannelName")
		Elseif ShowType=2 then
			Response.Write rrs("ClassName")
		Elseif ShowType=3 then
			Response.Write rrs("SpecialName")
		End if
	Else
		Response.write "找不到频道"	
	End if
	rrs.close
	set rrs=nothing
Else
	Response.write "未指定"	
End if
End Sub

Sub ShowItemList(ItemID)
   Dim SqlI,RsI  
   SqlI ="select ItemID,ItemName from Item order by ItemID desc"   
   Set RsI=server.CreateObject("adodb.recordset")   
   RsI.Open SqlI,ConnItem,1,1
   If RsI.Eof and RsI.Bof Then
      Response.write "<option value="""">请添加项目</option>"   
   Else   
      Do while not RsI.Eof   
         Response.Write "<option value=" & """" & RsI("ItemID") & """" & "" 
         If ItemID=RsI("ItemID") Then
            Response.Write " Selected"
         End If
         Response.Write ">" & RsI("ItemName")
         Response.Write "</option>"  
      RsI.Movenext   
      Loop   
   End if
   RsI.Close   
   Set RsI=Nothing   
End sub 


'UTF-8 to GBK转换
'参数:UTFStr 要转换的字符串
Function UTF2GB(UTFStr)
	Dim Dig,GBStr
    for Dig=1 to len(UTFStr)
        if mid(UTFStr,Dig,1)="%" then
            if len(UTFStr) >= Dig+8 then
                GBStr=GBStr & ConvChinese(mid(UTFStr,Dig,9))
                Dig=Dig+8
            else
                GBStr=GBStr & mid(UTFStr,Dig,1)
            end if
        else
            GBStr=GBStr & mid(UTFStr,Dig,1)
        end if
    next
    UTF2GB=GBStr
end function 


function ConvChinese(x) 
	Dim A,i,j,DigS,Unicode
    A=split(mid(x,2),"%")
    i=0
    j=0
    
    for i=0 to ubound(A) 
        A(i)=c16to2(A(i))
    next
        
    for i=0 to ubound(A)-1
        DigS=instr(A(i),"0")
        Unicode=""
        for j=1 to DigS-1
            if j=1 then 
                A(i)=right(A(i),len(A(i))-DigS)
                Unicode=Unicode & A(i)
            else
                i=i+1
                A(i)=right(A(i),len(A(i))-2)
                Unicode=Unicode & A(i) 
            end if 
        next
        
        if len(c2to16(Unicode))=4 then
            ConvChinese=ConvChinese & chrw(int("&H" & c2to16(Unicode)))
        else
            ConvChinese=ConvChinese & chr(int("&H" & c2to16(Unicode)))
        end if
    next
end function

function c2to16(x)
	Dim i
    i=1
    for i=1 to len(x)  step 4 
        c2to16=c2to16 & hex(c2to10(mid(x,i,4))) 
    next
end function 
    
function c2to10(x)
Dim i
    c2to10=0
    if x="0" then exit function
    i=0
    for i= 0 to len(x) -1
        if mid(x,len(x)-i,1)="1" then c2to10=c2to10+2^(i)
    next 
end function

function c16to2(x)
Dim i,tempstr
    i=0
    for i=1 to len(trim(x)) 
        tempstr= c10to2(cint(int("&h" & mid(x,i,1))))
        do while len(tempstr)<4
        tempstr="0" & tempstr
        loop
        c16to2=c16to2 & tempstr
    next
end function

function c10to2(x)
Dim mysign,DigS,tempnum
    mysign=sgn(x)
    x=abs(x)
    DigS=1
    do 
        if x<2^DigS then
            exit do
        else
            DigS=DigS+1
        end if
    loop
    tempnum=x
    
    i=0
    for i=DigS to 1 step-1
        if tempnum>=2^(i-1) then
            tempnum=tempnum-2^(i-1)
            c10to2=c10to2 & "1"   
        else
            c10to2=c10to2 & "0"
        end if
    next
    if mysign=-1 then c10to2="-" & c10to2
end function


Function ReplaceKeyChar(strChar)
	dim i,tmstr
    If strChar = "" Then
        ReplaceBadChar = ""
    Else
    	StrChar=replace(StrChar,"&nbsp;","")
    	for i=1 to len(strChar)
    		if (asc(mid(strChar,i,1))>31 and asc(mid(strChar,i,1))<48) or (asc(mid(strChar,i,1))>57 and asc(mid(strChar,i,1))<65) or (asc(mid(strChar,i,1))>90 and asc(mid(strChar,i,1))<97) or (asc(mid(strChar,i,1))>122 and asc(mid(strChar,i,1))<124)  or (asc(mid(strChar,i,1))>124 and asc(mid(strChar,i,1))<127)  then
			else
				tmstr=tmstr&mid(strChar,i,1)
			end if
    	next
    	ReplaceKeyChar=tmstr
    End If
End Function

'格式化字符串为数字
Function FormatNum(str)
	Dim i,tempstr,tempwd
	str=Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(str,"９","9"),"８","8"),"７","7"),"６","6"),"５","5"),"４","4"),"３","3"),"２","2"),"１","1"),"０","0")
	for i=1 to len(str)
		if asc(mid(str,i,1))>47 and asc(mid(str,i,1))<58 then tempstr=tempstr&mid(str,i,1)
	Next
	FormatNum=tempstr
	'FormatNum=0
End Function




'显示最新采集时间
Sub ShowcollecDate(ID)
	dim rrs,rsql
	set rrs=server.createobject("adodb.recordset")
	rsql="select Top 1 NewscollecDate from HistrolyNews where ItemID="&ID&" order by NewscollecDate desc"
	rrs.open rsql,ConnItem,1,1
	if not(rrs.eof and rrs.bof) then
		Response.Write rrs("NewscollecDate")
	End if
	rrs.close
	set rrs=nothing
End Sub

'显示失败数
Sub ShowFailNum(ID)
	dim rrs,rsql
	set rrs=server.createobject("adodb.recordset")
	rsql="select NewscollecDate from HistrolyNews where Result=False and ItemID="&ID&""
	rrs.open rsql,ConnItem,1,1
	if not(rrs.eof and rrs.bof) then
		rrs.PageSize=1
		Response.Write rrs.PageCount
	Else
		Response.write "0"
	End if	
	rrs.close
	set rrs=nothing
End Sub

'显示成功数
Sub ShowSuccNum(ID)
	dim rrs,rsql
	set rrs=server.createobject("adodb.recordset")
	rsql="select NewscollecDate from HistrolyNews where Result=True and ItemID="&ID&""
	rrs.open rsql,ConnItem,1,1
	if not(rrs.eof and rrs.bof) then
		rrs.PageSize=1
		Response.Write rrs.PageCount
	Else
		Response.write "0"
	End if
	rrs.close
	set rrs=nothing
End Sub





%>