<%
'================================================================================================
' 軟件名稱：清風信息自動采集生成系統
' 當前版本：CJ 1.0
' 更新日期：2008-7-18
' 程序版權：龍心數據
' 程序開發：龍心數據開發組
' 演示站點：http://cj.iising.com
' 官方網站：http://www.iising.com  QQ：24387481 電話：13719316070
' 鄭重聲明:
'    ①、沒有版權,你愛抄抄,愛搬搬,偶看不見!
'    ②、不要用黑與白來衡量你我之間的距離,更不要讓生活磨滅我們的個性！
'    ③、歡迎定做各種信息采集功能系統。
'================================================================================================

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