创力采集程序用到的函数 推荐第1/3页 复制代码 代码如下:<% '================================================== '过程名：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="" If Rsc.Eof and Rsc.Bof Then TempStr=TempStr & "" Else Do while not Rsc.Eof TempStr=TempStr & "" 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="" 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 123下一页阅读全文
