创力采集程序用到的函数 推荐第13页

　　复制代码 代码如下:
<%
==================================================
过程名：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=ItemIDID=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.openGET,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.OpenPOST,PostUrl,False
XmlHTTP.setRequestHeaderContent-Length,Len(PostData)
xmlHttp.setRequestHeaderContent-Type,application/x-
xmlHttp.setRequestHeaderReferer,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
123下一页阅读全文