創力采集程序用到的函數 推薦第1/3頁

　　復制代碼 代碼如下:

　　<%
==================================================
過程名Admin_ShowChannel_Name
作  用顯示頻道名稱
參  數ChannelID 頻道ID
==================================================
Sub Admin_ShowChannel_Name(ChannelID)
   Dim SqlcRscTempStr
   ChannelID=Clng(ChannelID)
   Sqlc =select top  ChannelName from Cl_Channel Where ChannelID= & ChannelID   
   Set Rsc=serverCreateObject(adodbrecordset)
   OpenConn : Rscopen SqlcConn
   If RscEof and RscBof then
      TempStr=無指定頻道   
   Else   
      TempStr=Rsc(ChannelName)
   End if
   RscClose : Set Rsc=Nothing
   responsewrite TempStr
End Sub

==================================================
過程名Admin_ShowChannel_Option
作  用顯示頻道選項
參  數ChannelID 頻道ID
==================================================
Sub Admin_ShowChannel_Option(ChannelID)
   Dim SqlcRscChannelNameTempStr
   ChannelID=Clng(ChannelID)
   Sqlc =select ChannelIDChannelName from Cl_Channel where ChannelID> and ChannelID<> and 
ChannelType< and ModuleID=
   Set Rsc=serverCreateObject(adodbrecordset)
   OpenConn : RscOpen SqlcConn
   TempStr=<option value=>請選擇頻道</option>
   If RscEof and RscBof Then
      TempStr=TempStr & <option value=>請添加頻道</option>   
   Else
      Do while not RscEof   
         TempStr=TempStr & <option value= &  & Rsc(ChannelID) &  &  
         If ChannelID=Rsc(ChannelID) Then
            TempStr=TempStr &  Selected
         End If
         TempStr=TempStr & > & Rsc(ChannelName)
         TempStr=TempStr & </option>  
      RscMovenext   
      Loop   
   End if
   RscClose   
   Set Rsc=Nothing   
   ResponseWrite TempStr   
End sub 


==================================================
過程名Admin_ShowClass_Name
作  用顯示欄目名稱
參  數ChannelID 頻道ID
參  數ClassID 欄目ID
==================================================
Sub Admin_ShowClass_Name(ChannelIDClassID)   
   Dim SqlCRsCTempStr
   ChannelID=Clng(ChannelID)
   ClassID=Clng(ClassID)
   Sqlc =Select top  ClassName from Cl_Class Where ChannelID= & ChannelID &  and ClassID= & ClassID   
   Set RsC=serverCreateObject(adodbrecordset)   
   OpenConn : RsCOpen SqlCConn   
   If RsCEof And RsCBof Then   
      TempStr=無指定欄目   
   Else   
      TempStr=RsC(ClassName)
   End if   
   RsCClose : Set RsC=Nothing
   ResponseWrite TempStr   
End Sub  

==================================================
過程名Admin_ShowSpecial_Name
作  用顯示專題名稱
參  數ChannelID 頻道ID
參  數SpecialID 專題ID
==================================================
Sub Admin_ShowSpecial_Name(ChannelIDSpecialID)   
   Dim SqlcRscTempStr
   ChannelID=Clng(ChannelID)
   SpecialID=Clng(SpecialID)
   Sqlc =select top  SpecialName from Cl_Special Where SpecialID= & SpecialID   
   Set Rsc=serverCreateObject(adodbrecordset)   
   OpenConn : Rscopen SqlcConn   
   If RscEof and RscBof then   
      TempStr=無指定專題   
   Else   
      TempStr=Rsc(SpecialName)
   End if   
   RscClose : Set Rsc=Nothing
   ResponseWrite TempStr   
End Sub  

==================================================
過程名Admin_ShowItem_Name
作  用顯示項目名稱
參  數ItemID 項目ID
==================================================
Sub Admin_ShowItem_Name(ItemID)   
   Dim SqlcRscTempStr
   ItemID=Clng(ItemID)
   Sqlc =select top  ItemName from Item Where ItemID= & ItemID   
   Set Rsc=serverCreateObject(adodbrecordset)   
   Rscopen SqlcConnItem   
   If RscEof and RscBof then   
      TempStr=無指定項目   
   Else   
      TempStr=Rsc(ItemName)
   End if   
   RscClose : Set Rsc=Nothing
   ResponseWrite TempStr   
End Sub  

==================================================
過程名Admin_ShowItem_Option
作  用顯示項目選項
參  數ItemID 項目ID
==================================================
Sub Admin_ShowItem_Option(ItemID)   
   Dim SqlIRsITempStr
   ItemID=Clng(ItemID)
   SqlI =select ItemIDItemName from Item order by ItemID desc   
   Set RsI=serverCreateObject(adodbrecordset)   
   RsIOpen SqlIConnItem
   TempStr=<select Name=ItemID ID=ItemID>   
   If RsIEof and RsIBof Then
      TempStr=TempStr & <option value=>請添加項目</option>   
   Else   
      TempStr=TempStr & <option value=>請選擇項目</option>
      Do while not RsIEof   
         TempStr=TempStr & <option value= &  & RsI(ItemID) &  &  
         If ItemID=RsI(ItemID) Then
            TempStr=TempStr &  Selected
         End If
         TempStr=TempStr & > & RsI(ItemName)
         TempStr=TempStr & </option>  
      RsIMovenext   
      Loop   
   End if
   RsIClose   
   Set RsI=Nothing   
   TempStr=TempStr & </select>
   ResponseWrite TempStr   
End sub   

==================================================
函數名GetHttpPage
作  用獲取網頁源碼
參  數HttpUrl 網頁地址
==================================================
Function GetHttpPage(HttpUrl)
   If IsNull(HttpUrl)=True Or Len(HttpUrl)< Or HttpUrl=$False$ Then
      GetHttpPage=$False$
      Exit Function
   End If
   Dim Http
   On Error Resume Next
   Set Http=servercreateobject(MSXMLXMLHTTP)
   Httpopen GETHttpUrlFalse
   HttpSend()
   If HttpReadystate<> then
      Set Http=Nothing 
      GetHttpPage=$False$
      Exit function
   End if
   GetHTTPPage=bytesToBSTR(HttpresponseBodyGB)
   Set Http=Nothing
   If Errnumber<> then ErrClear
End Function

==================================================
函數名BytesToBstr
作  用將獲取的源碼轉換為中文
參  數Body 要轉換的變量
參  數Cset 要轉換的類型
==================================================
Function BytesToBstr(BodyCset)
   Dim Objstream
   On Error Resume Next
   Set Objstream = ServerCreateObject(Adodb & Str & eam)
   objstreamType = 
   objstreamMode =
   objstreamOpen
   objstreamWrite body
   objstreamPosition = 
   objstreamType = 
   objstreamCharset = Cset
   BytesToBstr = objstreamReadText 
   objstreamClose
   set objstream = Nothing
End Function

==================================================
函數名PostHttpPage
作  用登錄
==================================================
Function PostHttpPage(RefererUrlPostUrlPostData) 
    Dim xmlHttp 
    Dim RetStr
    On Error Resume Next
    Set xmlHttp = CreateObject(MsxmlXMLHTTP)  
    xmlHttpOpen POST PostUrl False
    XmlHTTPsetRequestHeader ContentLengthLen(PostData) 
    xmlHttpsetRequestHeader ContentType application/xwwwformurlencoded
    xmlHttpsetRequestHeader Referer RefererUrl
    xmlHttpSend PostData 
    If ErrNumber <>  Then
        Set xmlHttp=Nothing
        PostHttpPage = $False$
        Exit Function
    End If
    PostHttpPage=bytesToBSTR(xmlHttpresponseBodyGB)
    Set xmlHttp = Nothing
End Function 

==================================================
函數名UrlEncoding
作  用轉換編碼
==================================================
Function UrlEncoding(DataStr)
    Dim StrReturnSiThisChrInnerCodeHightLow
    StrReturn = 
    For Si =  To Len(DataStr)
        ThisChr = Mid(DataStrSi)
        If Abs(Asc(ThisChr)) < &HFF Then
            StrReturn = StrReturn & ThisChr
        Else
            InnerCode = Asc(ThisChr)
            If InnerCode <  Then
               InnerCode = InnerCode + &H
            End If
            Hight = (InnerCode  And &HFF)\ &HFF
            Low = InnerCode And &HFF
            StrReturn = StrReturn & % & Hex(Hight) &  % & Hex(Low)
        End If
    Next
    UrlEncoding = StrReturn
End Function

==================================================
函數名GetBody
作  用截取字符串
參  數ConStr 將要截取的字符串
參  數StartStr 開始字符串
參  數OverStr 結束字符串
參  數IncluL 是否包含StartStr
參  數IncluR 是否包含OverStr
==================================================
Function GetBody(ConStrStartStrOverStrIncluLIncluR)
   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 StartOver
   ConStrTemp=Lcase(ConStr)
   StartStr=Lcase(StartStr)
   OverStr=Lcase(OverStr)
   Start = InStrB( ConStrTemp StartStr vbBinaryCompare)
   If Start<= then
      GetBody=$False$
      Exit Function
   Else
      If IncluL=False Then
         Start=Start+LenB(StartStr)
      End If
   End If
   Over=InStrB(StartConStrTempOverStrvbBinaryCompare)
   If Over<= Or Over<=Start then
      GetBody=$False$
      Exit Function
   Else
      If IncluR=True Then
         Over=Over+LenB(OverStr)
      End If
   End If
   GetBody=MidB(ConStrStartOverStart)
End Function

==================================================
函數名GetArray
作  用提取鏈接地址以$Array$分隔
參  數ConStr 提取地址的原字符
參  數StartStr 開始字符串
參  數OverStr 結束字符串
參  數IncluL 是否包含StartStr
參  數IncluR 是否包含OverStr
==================================================
Function GetArray(Byval ConStrStartStrOverStrIncluLIncluR)
   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 TempStrTempStrobjRegExpMatchesMatch
   TempStr=
   Set objRegExp = New Regexp 
   objRegExpIgnoreCase = True 
   objRegExpGlobal = True
   objRegExpPattern = (&StartStr&)+?(&OverStr&)
   Set Matches =objRegExpExecute(ConStr) 
   For Each Match in Matches
      TempStr=TempStr & $Array$ & MatchValue
   Next 
   Set Matches=Nothing

   If TempStr= Then
      GetArray=$False$
      Exit Function
   End If
   TempStr=Right(TempStrLen(TempStr))
   If IncluL=False then
      objRegExpPattern =StartStr
      TempStr=objRegExpReplace(TempStr)
   End if
   If IncluR=False then
      objRegExpPattern =OverStr
      TempStr=objRegExpReplace(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

From:http://tw.wingwit.com/Article/program/Web/201404/30645.html