|
|
复制代码 代码如下:
<%
'==================================================
'过程名：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
复制代码 代码如下:
'==================================================
'函数名：DefiniteUrl
'作 用：将相对地址转换为绝对地址
'参 数：PrimitiveUrl ------要转换的相对地址
'参 数：ConsultUrl ------当前网页地址
'==================================================
Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
If PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$False$" or ConsultUrl="$False$" Then
DefiniteUrl="$False$"
Exit Function
End If
If Left(Lcase(ConsultUrl),7)<>"http://" Then
ConsultUrl= "http://" & ConsultUrl
End If
ConsultUrl=Replace(ConsultUrl,"\","/")
ConsultUrl=Replace(ConsultUrl,"://",":\\")
PrimitiveUrl=Replace(PrimitiveUrl,"\","/")
If Right(ConsultUrl,1)<>"/" Then
If Instr(ConsultUrl,"/")>0 Then
If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then
ConsultUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/"))
Else
ConsultUrl=ConsultUrl & "/"
End If
Else
ConsultUrl=ConsultUrl & "/"
End If
End If
ConArray=Split(ConsultUrl,"/")
If Left(LCase(PrimitiveUrl),7) = "http://" then
DefiniteUrl=Replace(PrimitiveUrl,"://",":\\")
ElseIf Left(PrimitiveUrl,1) = "/" Then
DefiniteUrl=ConArray(0) & Replace(PrimitiveUrl,"../","")
ElseIf Left(PrimitiveUrl,2)="./" Then
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)
If Right(ConsultUrl,1)="/" Then
DefiniteUrl=ConsultUrl & PrimitiveUrl
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
End If
ElseIf Left(PrimitiveUrl,3)="../" then
Pi=0
Do While Left(PrimitiveUrl,3)="../"
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Loop
If Ubound(ConArray)-Pi>0 Then
For Ci=0 to (Ubound(ConArray)-Pi)
If DefiniteUrl<>"" Then
DefiniteUrl=DefiniteUrl & "/"
Else
DefiniteUrl=ConArray(Ci)
End If
Next
DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl
Else
DefiniteUrl=ConArray(0) & "/" & PrimitiveUrl
End if
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(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),4)=".com" or right
(LCase(PrimitiveUrl),4)=".net" or right(LCase(PrimitiveUrl),4)=".org" or right(LCase(PrimitiveUrl),5)
=".info" Then
DefiniteUrl="http:\\" & PrimitiveUrl & "/"
Else
DefiniteUrl=ConsultUrl & PrimitiveUrl
End If
Else
If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),4)=".com" or right
(LCase(PrimitiveUrl),4)=".net" or right(LCase(PrimitiveUrl),4)=".org" or right(LCase(PrimitiveUrl),5)
=".info" 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 ------ 要替换的字符串
'参 数：SaveTf ------ 是否保存文件，False不保存，True保存
'参 数: TistUrl------ 当前网页地址
'==================================================
Function ReplaceSaveRemoteFile(ConStr,strInstallDir,strChannelDir,SaveTf,TistUrl)
If ConStr="$False$" or ConStr="" or strInstallDir="" or strChannelDir="" Then
ReplaceSaveRemoteFile=ConStr
Exit Function
End If
Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
Re.Pattern ="<img.+?[^\>]>"
Set Matches =Re.Execute(ConStr)
For Each Match in Matches
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
Next
If TempStr<>"" Then
TempArray=Split(TempStr,"$Array$")
TempStr=""
For Tempi=0 To Ubound(TempArray)
Re.Pattern ="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"
Set Matches =Re.Execute(TempArray(Tempi))
For Each Match in Matches
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
Next
Next
End if
If TempStr<>"" Then
Re.Pattern ="src\s*=\s*"
TempStr=Re.Replace(TempStr,"")
End If
Set Matches=Nothing
Set Re=Nothing
If TempStr="" or IsNull(TempStr)=True Then
ReplaceSaveRemoteFile=ConStr
Exit function
End if
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
Dim RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path
DtNow=Now()
If SaveTf=True then
SavePath=Cl.UpLoadDir & "Editor/" & year(DtNow) &"-"& month(DtNow) & "/"
Arr_Path=Split(SavePath,"/")
PathTemp=""
For Tempi=0 To Ubound(Arr_Path)
If Tempi=0 Then
PathTemp=Arr_Path(0) & "/"
ElseIf Tempi=Ubound(Arr_Path) Then
Exit For
Else
PathTemp=PathTemp & Arr_Path(Tempi) & "/"
End If
If CheckDir(PathTemp)=False Then
If MakeNewsDir(PathTemp)=False Then
SaveTf=False
Exit For
End If
End If
Next
End If
'去掉重复图片开始
TempArray=Split(TempStr,"$Array$")
TempStr=""
For Tempi=0 To Ubound(TempArray)
If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
TempStr=TempStr & "$Array$" & TempArray(Tempi)
End If
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'去掉重复图片结束
'转换相对图片地址开始
TempStr=""
For Tempi=0 To Ubound(TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempStr=Replace(TempStr,Chr(0),"")
TempArray2=Split(TempStr,"$Array$")
TempStr=""
'转换相对图片地址结束
'图片替换/保存
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
For Tempi=0 To Ubound(TempArray2)
RemoteFileUrl=TempArray2(Tempi)
If RemoteFileUrl<>"$False$" And SaveTf=True Then'保存图片
ArrSaveFileName = Split(RemoteFileurl,".")
strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型
If strFileType="asp" or strFileType="asa" or strFileType="aspx" or strFileType="cer" or
strFileType="cdx" or strFileType="exe" or strFileType="rar" or strFileType="zip" then
UploadFiles=""
ReplaceSaveRemoteFile=ConStr
Exit Function
End If
Randomize
RanNum=Int(900*Rnd)+100
strFileName = year(DtNow) & right("0" & month(DtNow),2) & right("0" & day(DtNow),2) & right("0" &
hour(DtNow),2) & right("0" & minute(DtNow),2) & right("0" & second(DtNow),2) & ranNum & "." & strFileType
Re.Pattern =TempArray(Tempi)
If SaveRemoteFile(SavePath & strFileName,RemoteFileUrl)=True Then
PathTemp=Replace(SavePath &strFileName,Cl.UpLoadDir,"{%uploaddir%}")
ConStr=Re.Replace(ConStr,PathTemp)
Re.Pattern=strInstallDir & strChannelDir & "/"
UploadFiles=UploadFiles & "|" & Re.Replace(SavePath &strFileName,"")
Else
PathTemp=RemoteFileUrl
ConStr=Re.Replace(ConStr,PathTemp)
'UploadFiles=UploadFiles & "|" & RemoteFileUrl
End If
ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存图片
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
UploadFiles=UploadFiles & "|" & RemoteFileUrl
End If
Next
Set Re=Nothing
If UploadFiles<>"" Then
UploadFiles=Right(UploadFiles,Len(UploadFiles)-1)
End If
ReplaceSaveRemoteFile=ConStr
End function
'==================================================
'函数名：ReplaceSwfFile
'作 用：解析动画路径
'参 数：ConStr ------ 要替换的字符串
'参 数: TistUrl------ 当前网页地址
'==================================================
Function ReplaceSwfFile(ConStr,TistUrl)
If ConStr="$False$" or ConStr="" or TistUrl="" or TistUrl="$False$" Then
ReplaceSwfFile=ConStr
Exit Function
End If
Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
Re.Pattern ="<object.+?[^\>]>"
Set Matches =Re.Execute(ConStr)
For Each Match in Matches
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
Next
If TempStr<>"" Then
TempArray=Split(TempStr,"$Array$")
TempStr=""
For Tempi=0 To Ubound(TempArray)
Re.Pattern ="value\s*=\s*.+?\.swf"
Set Matches =Re.Execute(TempArray(Tempi))
For Each Match in Matches
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
Next
Next
End if
If TempStr<>"" Then
Re.Pattern ="value\s*=\s*"
TempStr=Re.Replace(TempStr,"")
End If
If TempStr="" or IsNull(TempStr)=True Then
ReplaceSwfFile=ConStr
Exit function
End if
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
Set Matches=Nothing
Set Re=Nothing
'去掉重复文件开始
TempArray=Split(TempStr,"$Array$")
TempStr=""
For Tempi=0 To Ubound(TempArray)
If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
TempStr=TempStr & "$Array$" & TempArray(Tempi)
End If
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'去掉重复文件结束
'转换相对地址开始
TempStr=""
For Tempi=0 To Ubound(TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempStr=Replace(TempStr,Chr(0),"")
TempArray2=Split(TempStr,"$Array$")
TempStr=""
'转换相对地址结束
'替换
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
For Tempi=0 To Ubound(TempArray2)
RemoteFileUrl=TempArray2(Tempi)
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
Next
Set Re=Nothing
ReplaceSwfFile=ConStr
End function
复制代码 代码如下:
'==================================================
'过程名：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
%>
复制代码 代码如下:
<%
'==================================================
'过程名：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
复制代码 代码如下:
'==================================================
'函数名：DefiniteUrl
'作 用：将相对地址转换为绝对地址
'参 数：PrimitiveUrl ------要转换的相对地址
'参 数：ConsultUrl ------当前网页地址
'==================================================
Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
If PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$False$" or ConsultUrl="$False$" Then
DefiniteUrl="$False$"
Exit Function
End If
If Left(Lcase(ConsultUrl),7)<>"http://" Then
ConsultUrl= "http://" & ConsultUrl
End If
ConsultUrl=Replace(ConsultUrl,"\","/")
ConsultUrl=Replace(ConsultUrl,"://",":\\")
PrimitiveUrl=Replace(PrimitiveUrl,"\","/")
If Right(ConsultUrl,1)<>"/" Then
If Instr(ConsultUrl,"/")>0 Then
If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then
ConsultUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/"))
Else
ConsultUrl=ConsultUrl & "/"
End If
Else
ConsultUrl=ConsultUrl & "/"
End If
End If
ConArray=Split(ConsultUrl,"/")
If Left(LCase(PrimitiveUrl),7) = "http://" then
DefiniteUrl=Replace(PrimitiveUrl,"://",":\\")
ElseIf Left(PrimitiveUrl,1) = "/" Then
DefiniteUrl=ConArray(0) & Replace(PrimitiveUrl,"../","")
ElseIf Left(PrimitiveUrl,2)="./" Then
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)
If Right(ConsultUrl,1)="/" Then
DefiniteUrl=ConsultUrl & PrimitiveUrl
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
End If
ElseIf Left(PrimitiveUrl,3)="../" then
Pi=0
Do While Left(PrimitiveUrl,3)="../"
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Loop
If Ubound(ConArray)-Pi>0 Then
For Ci=0 to (Ubound(ConArray)-Pi)
If DefiniteUrl<>"" Then
DefiniteUrl=DefiniteUrl & "/"
Else
DefiniteUrl=ConArray(Ci)
End If
Next
DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl
Else
DefiniteUrl=ConArray(0) & "/" & PrimitiveUrl
End if
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(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),4)=".com" or right
(LCase(PrimitiveUrl),4)=".net" or right(LCase(PrimitiveUrl),4)=".org" or right(LCase(PrimitiveUrl),5)
=".info" Then
DefiniteUrl="http:\\" & PrimitiveUrl & "/"
Else
DefiniteUrl=ConsultUrl & PrimitiveUrl
End If
Else
If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),4)=".com" or right
(LCase(PrimitiveUrl),4)=".net" or right(LCase(PrimitiveUrl),4)=".org" or right(LCase(PrimitiveUrl),5)
=".info" 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 ------ 要替换的字符串
'参 数：SaveTf ------ 是否保存文件，False不保存，True保存
'参 数: TistUrl------ 当前网页地址
'==================================================
Function ReplaceSaveRemoteFile(ConStr,strInstallDir,strChannelDir,SaveTf,TistUrl)
If ConStr="$False$" or ConStr="" or strInstallDir="" or strChannelDir="" Then
ReplaceSaveRemoteFile=ConStr
Exit Function
End If
Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
Re.Pattern ="<img.+?[^\>]>"
Set Matches =Re.Execute(ConStr)
For Each Match in Matches
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
Next
If TempStr<>"" Then
TempArray=Split(TempStr,"$Array$")
TempStr=""
For Tempi=0 To Ubound(TempArray)
Re.Pattern ="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"
Set Matches =Re.Execute(TempArray(Tempi))
For Each Match in Matches
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
Next
Next
End if
If TempStr<>"" Then
Re.Pattern ="src\s*=\s*"
TempStr=Re.Replace(TempStr,"")
End If
Set Matches=Nothing
Set Re=Nothing
If TempStr="" or IsNull(TempStr)=True Then
ReplaceSaveRemoteFile=ConStr
Exit function
End if
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
Dim RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path
DtNow=Now()
If SaveTf=True then
SavePath=Cl.UpLoadDir & "Editor/" & year(DtNow) &"-"& month(DtNow) & "/"
Arr_Path=Split(SavePath,"/")
PathTemp=""
For Tempi=0 To Ubound(Arr_Path)
If Tempi=0 Then
PathTemp=Arr_Path(0) & "/"
ElseIf Tempi=Ubound(Arr_Path) Then
Exit For
Else
PathTemp=PathTemp & Arr_Path(Tempi) & "/"
End If
If CheckDir(PathTemp)=False Then
If MakeNewsDir(PathTemp)=False Then
SaveTf=False
Exit For
End If
End If
Next
End If
'去掉重复图片开始
TempArray=Split(TempStr,"$Array$")
TempStr=""
For Tempi=0 To Ubound(TempArray)
If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
TempStr=TempStr & "$Array$" & TempArray(Tempi)
End If
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'去掉重复图片结束
'转换相对图片地址开始
TempStr=""
For Tempi=0 To Ubound(TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempStr=Replace(TempStr,Chr(0),"")
TempArray2=Split(TempStr,"$Array$")
TempStr=""
'转换相对图片地址结束
'图片替换/保存
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
For Tempi=0 To Ubound(TempArray2)
RemoteFileUrl=TempArray2(Tempi)
If RemoteFileUrl<>"$False$" And SaveTf=True Then'保存图片
ArrSaveFileName = Split(RemoteFileurl,".")
strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型
If strFileType="asp" or strFileType="asa" or strFileType="aspx" or strFileType="cer" or
strFileType="cdx" or strFileType="exe" or strFileType="rar" or strFileType="zip" then
UploadFiles=""
ReplaceSaveRemoteFile=ConStr
Exit Function
End If
Randomize
RanNum=Int(900*Rnd)+100
strFileName = year(DtNow) & right("0" & month(DtNow),2) & right("0" & day(DtNow),2) & right("0" &
hour(DtNow),2) & right("0" & minute(DtNow),2) & right("0" & second(DtNow),2) & ranNum & "." & strFileType
Re.Pattern =TempArray(Tempi)
If SaveRemoteFile(SavePath & strFileName,RemoteFileUrl)=True Then
PathTemp=Replace(SavePath &strFileName,Cl.UpLoadDir,"{%uploaddir%}")
ConStr=Re.Replace(ConStr,PathTemp)
Re.Pattern=strInstallDir & strChannelDir & "/"
UploadFiles=UploadFiles & "|" & Re.Replace(SavePath &strFileName,"")
Else
PathTemp=RemoteFileUrl
ConStr=Re.Replace(ConStr,PathTemp)
'UploadFiles=UploadFiles & "|" & RemoteFileUrl
End If
ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存图片
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
UploadFiles=UploadFiles & "|" & RemoteFileUrl
End If
Next
Set Re=Nothing
If UploadFiles<>"" Then
UploadFiles=Right(UploadFiles,Len(UploadFiles)-1)
End If
ReplaceSaveRemoteFile=ConStr
End function
'==================================================
'函数名：ReplaceSwfFile
'作 用：解析动画路径
'参 数：ConStr ------ 要替换的字符串
'参 数: TistUrl------ 当前网页地址
'==================================================
Function ReplaceSwfFile(ConStr,TistUrl)
If ConStr="$False$" or ConStr="" or TistUrl="" or TistUrl="$False$" Then
ReplaceSwfFile=ConStr
Exit Function
End If
Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
Re.Pattern ="<object.+?[^\>]>"
Set Matches =Re.Execute(ConStr)
For Each Match in Matches
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
Next
If TempStr<>"" Then
TempArray=Split(TempStr,"$Array$")
TempStr=""
For Tempi=0 To Ubound(TempArray)
Re.Pattern ="value\s*=\s*.+?\.swf"
Set Matches =Re.Execute(TempArray(Tempi))
For Each Match in Matches
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
Next
Next
End if
If TempStr<>"" Then
Re.Pattern ="value\s*=\s*"
TempStr=Re.Replace(TempStr,"")
End If
If TempStr="" or IsNull(TempStr)=True Then
ReplaceSwfFile=ConStr
Exit function
End if
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
Set Matches=Nothing
Set Re=Nothing
'去掉重复文件开始
TempArray=Split(TempStr,"$Array$")
TempStr=""
For Tempi=0 To Ubound(TempArray)
If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
TempStr=TempStr & "$Array$" & TempArray(Tempi)
End If
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'去掉重复文件结束
'转换相对地址开始
TempStr=""
For Tempi=0 To Ubound(TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Next
TempStr=Right(TempStr,Len(TempStr)-7)
TempStr=Replace(TempStr,Chr(0),"")
TempArray2=Split(TempStr,"$Array$")
TempStr=""
'转换相对地址结束
'替换
Set Re = New Regexp
Re.IgnoreCase = True
Re.Global = True
For Tempi=0 To Ubound(TempArray2)
RemoteFileUrl=TempArray2(Tempi)
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
Next
Set Re=Nothing
ReplaceSwfFile=ConStr
End function
复制代码 代码如下:
'==================================================
'过程名：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
%>
|
|
发表于 2006-9-1 00:00:00
