复制代码 代码如下:
<%
'==================================================
'过程名：Admin_ShowChannel_Name
'作用：显示频道名称
'参数：ChannelID------频道ID
'==================================================
SubAdmin_ShowChannel_Name(ChannelID)
DimSqlc,Rsc,TempStr
ChannelID=Clng(ChannelID)
Sqlc="selecttop1ChannelNamefromCl_ChannelWhereChannelID="&ChannelID
SetRsc=server.CreateObject("adodb.recordset")
OpenConn:Rsc.openSqlc,Conn,1,1
IfRsc.EofandRsc.Bofthen
TempStr="无指定频道"
Else
TempStr=Rsc("ChannelName")
Endif
Rsc.Close:SetRsc=Nothing
response.writeTempStr
EndSub
'==================================================
'过程名：Admin_ShowChannel_Option
'作用：显示频道选项
'参数：ChannelID------频道ID
'==================================================
SubAdmin_ShowChannel_Option(ChannelID)
DimSqlc,Rsc,ChannelName,TempStr
ChannelID=Clng(ChannelID)
Sqlc="selectChannelID,ChannelNamefromCl_ChannelwhereChannelID>0andChannelID<>6and
ChannelType<2andModuleID=1"
SetRsc=server.CreateObject("adodb.recordset")
OpenConn:Rsc.OpenSqlc,Conn,1,1
TempStr="<optionvalue=""0"">请选择频道</option>"
IfRsc.EofandRsc.BofThen
TempStr=TempStr&"<optionvalue=""0"">请添加频道</option>"
Else
DowhilenotRsc.Eof
TempStr=TempStr&"<optionvalue="&""""&Rsc("ChannelID")&""""&""
IfChannelID=Rsc("ChannelID")Then
TempStr=TempStr&"Selected"
EndIf
TempStr=TempStr&">"&Rsc("ChannelName")
TempStr=TempStr&"</option>"
Rsc.Movenext
Loop
Endif
Rsc.Close
SetRsc=Nothing
Response.WriteTempStr
Endsub
'==================================================
'过程名：Admin_ShowClass_Name
'作用：显示栏目名称
'参数：ChannelID------频道ID
'参数：ClassID------栏目ID
'==================================================
SubAdmin_ShowClass_Name(ChannelID,ClassID)
DimSqlC,RsC,TempStr
ChannelID=Clng(ChannelID)
ClassID=Clng(ClassID)
Sqlc="Selecttop1ClassNamefromCl_ClassWhereChannelID="&ChannelID&"andClassID="&ClassID
SetRsC=server.CreateObject("adodb.recordset")
OpenConn:RsC.OpenSqlC,Conn,1,1
IfRsC.EofAndRsC.BofThen
TempStr="无指定栏目"
Else
TempStr=RsC("ClassName")
Endif
RsC.Close:SetRsC=Nothing
Response.WriteTempStr
EndSub
'==================================================
'过程名：Admin_ShowSpecial_Name
'作用：显示专题名称
'参数：ChannelID------频道ID
'参数：SpecialID------专题ID
'==================================================
SubAdmin_ShowSpecial_Name(ChannelID,SpecialID)
DimSqlc,Rsc,TempStr
ChannelID=Clng(ChannelID)
SpecialID=Clng(SpecialID)
Sqlc="selecttop1SpecialNamefromCl_SpecialWhereSpecialID="&SpecialID
SetRsc=server.CreateObject("adodb.recordset")
OpenConn:Rsc.openSqlc,Conn,1,1
IfRsc.EofandRsc.Bofthen
TempStr="无指定专题"
Else
TempStr=Rsc("SpecialName")
Endif
Rsc.Close:SetRsc=Nothing
Response.WriteTempStr
EndSub
'==================================================
'过程名：Admin_ShowItem_Name
'作用：显示项目名称
'参数：ItemID------项目ID
'==================================================
SubAdmin_ShowItem_Name(ItemID)
DimSqlc,Rsc,TempStr
ItemID=Clng(ItemID)
Sqlc="selecttop1ItemNamefromItemWhereItemID="&ItemID
SetRsc=server.CreateObject("adodb.recordset")
Rsc.openSqlc,ConnItem,1,1
IfRsc.EofandRsc.Bofthen
TempStr="无指定项目"
Else
TempStr=Rsc("ItemName")
Endif
Rsc.Close:SetRsc=Nothing
Response.WriteTempStr
EndSub
'==================================================
'过程名：Admin_ShowItem_Option
'作用：显示项目选项
'参数：ItemID------项目ID
'==================================================
SubAdmin_ShowItem_Option(ItemID)
DimSqlI,RsI,TempStr
ItemID=Clng(ItemID)
SqlI="selectItemID,ItemNamefromItemorderbyItemIDdesc"
SetRsI=server.CreateObject("adodb.recordset")
RsI.OpenSqlI,ConnItem,1,1
TempStr="<selectName=""ItemID""ID=""ItemID"">"
IfRsI.EofandRsI.BofThen
TempStr=TempStr&"<optionvalue=""0"">请添加项目</option>"
Else
TempStr=TempStr&"<optionvalue=""0"">请选择项目</option>"
DowhilenotRsI.Eof
TempStr=TempStr&"<optionvalue="&""""&RsI("ItemID")&""""&""
IfItemID=RsI("ItemID")Then
TempStr=TempStr&"Selected"
EndIf
TempStr=TempStr&">"&RsI("ItemName")
TempStr=TempStr&"</option>"
RsI.Movenext
Loop
Endif
RsI.Close
SetRsI=Nothing
TempStr=TempStr&"</select>"
Response.WriteTempStr
Endsub
'==================================================
'函数名：GetHttpPage
'作用：获取网页源码
'参数：HttpUrl------网页地址
'==================================================
FunctionGetHttpPage(HttpUrl)
IfIsNull(HttpUrl)=TrueOrLen(HttpUrl)<18OrHttpUrl="$False$"Then
GetHttpPage="$False$"
ExitFunction
EndIf
DimHttp
OnErrorResumeNext
SetHttp=server.createobject("MSXML2.XMLHTTP")
Http.open"GET",HttpUrl,False
Http.Send()
IfHttp.Readystate<>4then
SetHttp=Nothing
GetHttpPage="$False$"
Exitfunction
Endif
GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
SetHttp=Nothing
IfErr.number<>0thenErr.Clear
EndFunction
'==================================================
'函数名：BytesToBstr
'作用：将获取的源码转换为中文
'参数：Body------要转换的变量
'参数：Cset------要转换的类型
'==================================================
FunctionBytesToBstr(Body,Cset)
DimObjstream
OnErrorResumeNext
SetObjstream=Server.CreateObject("Adodb."&"Str"&"eam")
objstream.Type=1
objstream.Mode=3
objstream.Open
objstream.Writebody
objstream.Position=0
objstream.Type=2
objstream.Charset=Cset
BytesToBstr=objstream.ReadText
objstream.Close
setobjstream=Nothing
EndFunction
'==================================================
'函数名：PostHttpPage
'作用：登录
'==================================================
FunctionPostHttpPage(RefererUrl,PostUrl,PostData)
DimxmlHttp
DimRetStr
OnErrorResumeNext
SetxmlHttp=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.SendPostData
IfErr.Number<>0Then
SetxmlHttp=Nothing
PostHttpPage="$False$"
ExitFunction
EndIf
PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
SetxmlHttp=Nothing
EndFunction
'==================================================
'函数名：UrlEncoding
'作用：转换编码
'==================================================
FunctionUrlEncoding(DataStr)
DimStrReturn,Si,ThisChr,InnerCode,Hight8,Low8
StrReturn=""
ForSi=1ToLen(DataStr)
ThisChr=Mid(DataStr,Si,1)
IfAbs(Asc(ThisChr))<&HFFThen
StrReturn=StrReturn&ThisChr
Else
InnerCode=Asc(ThisChr)
IfInnerCode<0Then
InnerCode=InnerCode+&H10000
EndIf
Hight8=(InnerCodeAnd&HFF00)&HFF
Low8=InnerCodeAnd&HFF
StrReturn=StrReturn&"%"&Hex(Hight8)&"%"&Hex(Low8)
EndIf
Next
UrlEncoding=StrReturn
EndFunction
'==================================================
'函数名：GetBody
'作用：截取字符串
'参数：ConStr------将要截取的字符串
'参数：StartStr------开始字符串
'参数：OverStr------结束字符串
'参数：IncluL------是否包含StartStr
'参数：IncluR------是否包含OverStr
'==================================================
FunctionGetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
IfConStr="$False$"orConStr=""orIsNull(ConStr)=TrueOrStartStr=""orIsNull(StartStr)=TrueOr
OverStr=""orIsNull(OverStr)=TrueThen
GetBody="$False$"
ExitFunction
EndIf
DimConStrTemp
DimStart,Over
ConStrTemp=Lcase(ConStr)
StartStr=Lcase(StartStr)
OverStr=Lcase(OverStr)
Start=InStrB(1,ConStrTemp,StartStr,vbBinaryCompare)
IfStart<=0then
GetBody="$False$"
ExitFunction
Else
IfIncluL=FalseThen
Start=Start+LenB(StartStr)
EndIf
EndIf
Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
IfOver<=0OrOver<=Startthen
GetBody="$False$"
ExitFunction
Else
IfIncluR=TrueThen
Over=Over+LenB(OverStr)
EndIf
EndIf
GetBody=MidB(ConStr,Start,Over-Start)
EndFunction
'==================================================
'函数名：GetArray
'作用：提取链接地址，以$Array$分隔
'参数：ConStr------提取地址的原字符
'参数：StartStr------开始字符串
'参数：OverStr------结束字符串
'参数：IncluL------是否包含StartStr
'参数：IncluR------是否包含OverStr
'==================================================
FunctionGetArray(ByvalConStr,StartStr,OverStr,IncluL,IncluR)
IfConStr="$False$"orConStr=""OrIsNull(ConStr)=TrueorStartStr=""OrOverStr=""orIsNull
(StartStr)=TrueOrIsNull(OverStr)=TrueThen
GetArray="$False$"
ExitFunction
EndIf
DimTempStr,TempStr2,objRegExp,Matches,Match
TempStr=""
SetobjRegExp=NewRegexp
objRegExp.IgnoreCase=True
objRegExp.Global=True
objRegExp.Pattern="("&StartStr&").+?("&OverStr&")"
SetMatches=objRegExp.Execute(ConStr)
ForEachMatchinMatches
TempStr=TempStr&"$Array$"&Match.Value
Next
SetMatches=Nothing
IfTempStr=""Then
GetArray="$False$"
ExitFunction
EndIf
TempStr=Right(TempStr,Len(TempStr)-7)
IfIncluL=Falsethen
objRegExp.Pattern=StartStr
TempStr=objRegExp.Replace(TempStr,"")
Endif
IfIncluR=Falsethen
objRegExp.Pattern=OverStr
TempStr=objRegExp.Replace(TempStr,"")
Endif
SetobjRegExp=Nothing
SetMatches=Nothing
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr,"","")
TempStr=Replace(TempStr,"(","")
TempStr=Replace(TempStr,")","")
IfTempStr=""then
GetArray="$False$"
Else
GetArray=TempStr
Endif
EndFunction
当前1/3页123下一页阅读全文