復(fù)制代碼 代碼如下:
%
'==================================================
'過程名:Admin_ShowChannel_Name
'作 用:顯示頻道名稱
'參 數(shù):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
'作 用:顯示頻道選項(xiàng)
'參 數(shù):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
ChannelType2 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"">請?zhí)砑宇l道/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
'作 用:顯示欄目名稱
'參 數(shù):ChannelID ------頻道ID
'參 數(shù):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
'作 用:顯示專題名稱
'參 數(shù):ChannelID ------頻道ID
'參 數(shù):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
'作 用:顯示項(xiàng)目名稱
'參 數(shù):ItemID ------項(xiàng)目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="無指定項(xiàng)目"
Else
TempStr=Rsc("ItemName")
End if
Rsc.Close : Set Rsc=Nothing
Response.Write TempStr
End Sub
'==================================================
'過程名:Admin_ShowItem_Option
'作 用:顯示項(xiàng)目選項(xiàng)
'參 數(shù):ItemID ------項(xiàng)目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"">請?zhí)砑禹?xiàng)目/option>"
Else
TempStr=TempStr "option value=""0"">請選擇項(xiàng)目/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
'==================================================
'函數(shù)名:GetHttpPage
'作 用:獲取網(wǎng)頁源碼
'參 數(shù):HttpUrl ------網(wǎng)頁地址
'==================================================
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
'==================================================
'函數(shù)名:BytesToBstr
'作 用:將獲取的源碼轉(zhuǎn)換為中文
'參 數(shù):Body ------要轉(zhuǎn)換的變量
'參 數(shù):Cset ------要轉(zhuǎn)換的類型
'==================================================
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
'==================================================
'函數(shù)名: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
'==================================================
'函數(shù)名:UrlEncoding
'作 用:轉(zhuǎn)換編碼
'==================================================
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
'==================================================
'函數(shù)名:GetBody
'作 用:截取字符串
'參 數(shù):ConStr ------將要截取的字符串
'參 數(shù):StartStr ------開始字符串
'參 數(shù):OverStr ------結(jié)束字符串
'參 數(shù):IncluL ------是否包含StartStr
'參 數(shù):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
'==================================================
'函數(shù)名:GetArray
'作 用:提取鏈接地址,以$Array$分隔
'參 數(shù):ConStr ------提取地址的原字符
'參 數(shù):StartStr ------開始字符串
'參 數(shù):OverStr ------結(jié)束字符串
'參 數(shù):IncluL ------是否包含StartStr
'參 數(shù):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
123下一頁閱讀全文