程式師世界 >> 編程語言 >> 網頁編程 >> ASP編程 >> 關於ASP編程 >> 創力采集程序用到的函數推薦第1/3頁

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

編輯：關於ASP編程

復制代碼代碼如下:
<%
'==================================================
'過程名：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="<option value=""0"">請選擇頻道</option>"
   If Rsc.Eof and Rsc.Bof Then
      TempStr=TempStr & "<option value=""0"">請添加頻道</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
'作  用：顯示欄目名稱
'參  數：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="<select Name=""ItemID"" ID=""ItemID"">"
   If RsI.Eof and RsI.Bof Then
      TempStr=TempStr & "<option value=""0"">請添加項目</option>"
   Else
      TempStr=TempStr & "<option value=""0"">請選擇項目</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

'==================================================
'函數名：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
當前1/3頁 123下一頁閱讀全文