sk_funcls.asp

清风信息自动采集生成系统 很好用的大家试试看

<%
'================================================================================================
' 软件名称：清风信息自动采集生成系统
' 当前版本：CJ 1.0
' 更新日期：2008-7-18
' 程序版权：龙心数据
' 程序开发：龙心数据开发组
' 演示站点：http://cj.iising.com
' 官方网站：http://www.iising.com  QQ：24387481 电话：[phone]
' 郑重声明:
'    ①、没有版权,你爱抄抄,爱搬搬,偶看不见!
'    ②、不要用黑与白来衡量你我之间的距离,更不要让生活磨灭我们的个性！
'    ③、欢迎定做各种信息采集功能系统。
'================================================================================================

Class FunCls
	Dim AllExtName '下载类型限制
	Dim MaxFileSize '下载类型限制
	Dim DownTimeout '超时设置
	Private Is_Admin'是否登陆
	'===============================================
	'启动类事件
	'===============================================
	Private Sub Class_Initialize()
		On Error Resume Next
		DownTimeout = 64 '超时设置
		MaxFileSize = 0'-- 下载大小限制
		AllExtName = "rm|swf"'-- 下载类型限制
	End Sub
	'===============================================
	'关闭类事件
	'===============================================
	Private Sub Class_Terminate()
		'-- Class_Terminate
	End Sub
	'===============================================
	'-- 超时设置
	'===============================================
	Public Property Let CjTimeout(ByVal NewValue)
		DownTimeout = NewValue
	End Property
	'===============================================
	'-- 下载类型限制
	'===============================================
	Public Property Let DownExtName(ByVal NewValue)
		AllExtName = NewValue
	End Property
	'===============================================
	'-- 下载大小限制
	'===============================================
	Public Property Let MaxSize(ByVal NewValue)
		MaxFileSize = NewValue * 1024
	End Property
	'===============================================
	'管理员验证
	'===============================================
	Public Function IsAdmin()
	IsAdmin=Is_Admin
	End FunCtion
	'===============================================
	'管理员验证
	'===============================================
	Sub Admin()
	dim Admin_name,Admin_type,P_Admin
			if request.Cookies(Site)("IsAdmin")=empty then response.Cookies(Site)("IsAdmin")=0
			if request.Cookies(Site)("IsAdmin")=1 then
				dim sql,rs
				sql = "select * from admin where username='"&request.Cookies(Site)("Admin_name")&"'"
				set rs = ConnItem.Execute(sql)
				if rs.eof and rs.bof then
					Is_Admin = False
					Admin_name=Empty
					Admin_type=Empty
				else
					Is_Admin=true
					Admin_name=request.Cookies(Site)("Admin_name")
					Admin_type=request.Cookies(Site)("Admin_type")
					response.Cookies(Site).Expires=DateAdd("s",3600,Now())
				end if
			else
				Is_Admin=false
				Admin_name=Empty
				Admin_type=Empty
			end if
	End Sub	
	'===============================================
	'函数名：G()
	'作  用：'取得Request.Querystring 或 Request.Form 的值
	'===============================================
	Public Function G(Str)
	 G = Replace(Replace(Request(Str), "'", ""), """", "")
	End Function
	'===============================================
	'函数名：ChkNumeric()
	'作  用：' 转换成LONG 变量型态。 
	'===============================================
	Public Function ChkNumeric(ByVal CHECK_ID)
		If CHECK_ID <> "" And IsNumeric(CHECK_ID) Then
			CHECK_ID = CLng(CHECK_ID)
		Else
			CHECK_ID = 0
		End If
		ChkNumeric = CHECK_ID
	End Function
	'===============================================
	'函数名：GetConfig
	'作  用：获取系统配置信息
	'参  数：  ConfigField相应的字段名称
	'返回值：相应字段的值
	'===============================================
	Public Function GetConfig(ByVal ConfigField)
	    IF Application(Site & "SiteConfig_" & ConfigField)="" Then
				   Dim ConfigRS:Set ConfigRS = Server.CreateObject("Adodb.Recordset")
				   On Error Resume Next
				   ConfigRS.Open ("Select * From SK_Config"), ConnItem, 1, 1
				   GetConfig = ConfigRS(ConfigField)
				   If Err.Number <> 0 Then GetConfig = "":Err.clear
				   ConfigRS.Close:Set ConfigRS = Nothing
				   Application(Site & "SiteConfig_" & ConfigField)=GetConfig
		Else
				 GetConfig=Application(Site & "SiteConfig_" & ConfigField)
		End If
	End Function
	'===============================================
	'函数名：GetItemConfig
	'作  用：获取采集基础配置信息
	'参  数：ConfigField相应的字段名称,CJID基础配置的ID号
	'===============================================
	Public Function GetItemConfig(ByVal ConfigField,CJID)
		   Dim ConfigRS:Set ConfigRS = Server.CreateObject("Adodb.Recordset")
		   On Error Resume Next
		   ConfigRS.Open ("Select * From SK_Cj where ID="& CJID), ConnItem, 1, 1
		   GetItemConfig = ConfigRS(ConfigField)
		   If Err.Number <> 0 Then GetItemConfig = "":Err.clear
		   ConfigRS.Close:Set ConfigRS = Nothing
	End Function
	'===============================================
	'函数名：GetHttpPage
	'作  用：获取网页源码
	'参  数：HttpUrl ------网页地址,Cset 编码
	'===============================================
	Function GetHttpPage(ByVal URL, ByVal Cset)
	Dim BlockStartTime
	On Error Resume Next
	Dim Http
	 If IsNull(URL)=True Or Len(URL)<18 Or URL="$False$" Then
		  GetHttpPage="$False$"
		  Exit Function
	   End If
	   BlockStartTime = Timer()
	   Set Http=server.createobject("MSXML2.XMLHTTP")
	   Http.open "GET",URL,False
	   Http.Send()
	  '循环等待数据接收
	   Dim temp,BlockTimeout 	   
	   BlockTimeout = 64
	   While (http.ReadyState <> 4)
		  ' 判断是否块超时
		   temp = Timer() - BlockStartTime
		   Response.Write(Timer())
		   If (temp > BlockTimeout) Then
			   http.abort
			   Set Http=Nothing 
			   GetHttpPage="$False$"
			   Exit function
			   Response.End
		   End If
		   http.waitForResponse 10000'等待1000毫秒
	   Wend
	   If Http.Readystate<>4 then
		  Set Http=Nothing 
		  GetHttpPage="$False$"
		  Exit function
	   End if
	   GetHTTPPage=bytesToBSTR(Http.responseBody,Cset)
	   Set Http=Nothing
	   
	   If Err.number<>0 then
		  If IsNull(URL)=True Or Len(URL)<18 Or URL="$False$" Then
		  GetHttpPage="$False$"
		  Exit Function
	   End If
	   Set Http=Nothing
		  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
	'作  用：截取固定的字符串
	'参  数：strHTML   ----原字符串
	'参  数: start ------ 开始字符串
	'参  数: Over ------ 结束字符串
	'参  数：IncluL ------是否包含StartStr
	'参  数：IncluR ------是否包含OverStr
	'===============================================
	Public Function GetBody(ByVal strHTML, ByVal Start, ByVal Over,IncluL,IncluR)
		Dim SS
		Dim Match
		Dim TempStr
		Dim strPattern
		Dim s,o  
		If IsNull(Start)=True Then GetBody="$False$" : Exit Function
		Start=ReplaceTrim(Start) : Over=ReplaceTrim(Over) : strHTML=strHTML
		s=Len(start) : o=Len(Over)

		If s = 0 Or o = 0  Then GetBody="$False$" : Exit Function
		strPattern = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(Over) & ")"
		On Error Resume Next
		Dim re
		Set re = New RegExp
		re.IgnoreCase = False
		re.Global = False
		re.Pattern = strPattern
		Set SS = re.Execute(strHTML)
		For Each Match In SS
			TempStr = Match.Value
		Next
		If TempStr="" Then'空字符串,结束函数名
		   GetBody="$False$"
		   Exit Function
	    End If
	   
		If IncluL=False then
			TempStr=Right(TempStr,Len(TempStr) -S)
	    End if
	    If IncluR=False then
			TempStr=Left(TempStr,Len(TempStr) - O)
	    End if	
		If Err.number<>0 then  '出错,结束函数名
		   GetBody="$False$"
		   Exit Function
		End If
		Set SS = Nothing
		Set re = Nothing
		GetBody = TempStr
		Exit Function
	End Function