function.asp

用ASP开发环境写出来的新闻采集系统

<%
'==================================================
'过程名：Admin_ShowChannel_Name
'作  用：显示频道名称
'参  数：ChannelID ------频道ID
'==================================================
Sub Admin_ShowChannel_Name(ChannelID)   
   Dim Sqlc,Rsc,TempStr
   ChannelID=Clng(ChannelID)
   Sqlc ="select top 1 ChannelName from PE_Channel Where ChannelID=" & ChannelID   
   Set Rsc=server.CreateObject("adodb.recordset")   
   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 PE_Channel where ModuleType=1 order by ChannelID asc"   
   Set Rsc=server.CreateObject("adodb.recordset")   
   Rsc.Open Sqlc,Conn,1,1  
   TempStr="<option value=""0"" selected>请选择频道</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 & ""
         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 PE_Class Where ChannelID=" & ChannelID & " and ClassID=" & ClassID   
   Set RsC=server.CreateObject("adodb.recordset")   
   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 PE_Special Where ChannelID=" & ChannelID & " and SpecialID=" & SpecialID   
   Set Rsc=server.CreateObject("adodb.recordset")   
   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_ShowClass_Option
'作  用：显示栏目选项
'参  数：ChannelID ------频道ID
'参  数：ClassID ------栏目ID
'==================================================
sub Admin_ShowClass_Option(ChannelID,ClassID)
	dim rsClass,sqlClass,strTempC,tmpDepth,i
	dim arrShowLine(20)
	ChannelID=Clng(ChannelID)
	ClassID=Clng(ClassID)
	for i=0 to ubound(arrShowLine)
		arrShowLine(i)=False
	next
        StrTempC=""
	sqlClass="Select * From PE_Class where channelid="& ChannelID & " order by RootID,OrderID"
	set rsClass=conn.execute(sqlClass)
	if rsClass.bof and rsClass.eof then 
		strTempC="<option value=''>请先添加栏目</option>"
	else
                do while not rsClass.eof
                        tmpDepth=rsClass("Depth")
			if rsClass("NextID")>0 then
				arrShowLine(tmpDepth)=True
			else
				arrShowLine(tmpDepth)=False
			end if
	        strTempC=StrTempC & "<option value='" & rsClass("ClassID") & "'"
		        if rsClass("ClassID")=ClassID then
			        strTempC=strTempC & ""
		        end if
			strTempC=strTempC & rsClass("ClassName")
			strTempC=strTempC & "</option>"
		rsClass.movenext
		loop
	end if
	rsClass.close
	set rsClass=nothing
	response.write strTempc
end sub

'==================================================
'过程名：Admin_ShowSpecial_Option
'作  用：显示专题选项
'参  数：ChannelID ------频道ID
'参  数：SpecialID ------专题ID
'==================================================
sub Admin_ShowSpecial_Option(ChannelID,SpecialID)
    ChannelID=Clng(ChannelID)
    SpecialID=Clng(SpecialID)
    Dim TempStr
	TempStr="<select name='SpecialID' id='SpecialID'><option value=''"
	if SpecialID=0 then
		TempStr=TempStr & " selected"
	end if
	TempStr=TempStr & ">不属于任何专题</option>"
	                
	dim sqlSpecial,rsSpecial
        sqlSpecial = "select * from PE_Special where ChannelID=" & ChannelID
	set rsSpecial=server.CreateObject("adodb.recordset")
	rsSpecial.open sqlSpecial,conn,1,1
	do while not rsSpecial.eof
		if rsSpecial("SpecialID")=SpecialID then
			TempStr=TempStr & "<option value='" & rsSpecial("SpecialID") & "' selected>" & rsSpecial("SpecialName") & "</option>"
		else
			TempStr=TempStr & "<option value='" & rsSpecial("SpecialID") & "'>" & rsSpecial("SpecialName") & "</option>"
		end if
	rsSpecial.movenext
	loop
	rsSpecial.close
        set rsSpecial = nothing
        Response.write TempStr
end sub



'==================================================
'过程名：Admin_ShowTemplate_Option
'作  用：显示设计模板选项
'参  数：TemplateID ------设计模板ID
'参  数：ChannelID-----
'==================================================
sub Admin_ShowTemplate_Option(ChannelID,TemplateType,TemplateID)
	dim sqlTemplate,rsTemplate,TempStr
    ChannelID=Clng(ChannelID)
    TempLateType=Clng(TempLateType)
    TempLateID=Clng(TempLateID)
	TempStr="<select name='TemplateID' id='TemplateID'><option value='0'>系统默认内容页模板</option>"
	sqlTemplate="select * from PE_Template where TemplateType=" & TemplateType & " And ChannelID=" & ChannelID
	set rsTemplate=server.CreateObject("adodb.recordset")
	rsTemplate.open sqlTemplate,conn,1,1
	if rsTemplate.bof and rsTemplate.eof then
	  	TempStr= TempStr & "<option value='0'>请你先添加模板</option>"
	else
	  	do while not rsTemplate.eof
	  		if rsTemplate("TemplateID")=TemplateID then
				TempStr= TempStr & "<option value='" & rsTemplate("TemplateID") & "' selected>" & rsTemplate("TemplateName") & "</option>"
			else		
				TempStr= TempStr & "<option value='" & rsTemplate("TemplateID") & "'>" & rsTemplate("TemplateName") & "</option>"
	  		end if		
			rsTemplate.movenext
	  	loop
	end if
	rsTemplate.close
	set rsTemplate=nothing
    TempStr= TempStr & "</select>"
    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
   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 If
End Function

'==================================================
'函数名：BytesToBstr
'作  用：将获取的源码转换为中文
'参  数：Body ------要转换的变量
'参  数：Cset ------要转换的类型
'==================================================
Function BytesToBstr(Body,Cset)
   Dim Objstream
   Set Objstream = Server.CreateObject("adodb.stream")
   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      
    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