function.asp

新闻采集系统1.0.2 For 4.03(2005.05.15更新) 【使用环境】 本系统是基于动易4.03免费版的基础上的新闻采集系统

<%
'================版权信息=================
'程序编写：goaler
'个人主页：http://blog.goalercn.com
'程序演示：http://www.goalercn.com/article
'联系ＱＱ：13501615
'您可以任意修改本程序，但请保留以下版权信息，谢谢合作
'=========================================

'****************************************************
'防SQL注入函数
'函数功能：过滤字符参数中的单引号，对于数字参数进行判断，如果不是数值类型，则赋值0 
'参数意义：str ---- 要过滤的参数 
'strType ---- 参数类型，分为字符型和数字型，字符型为"s"，数字型为"i" 
'****************************************************
Function CheckStr(str,strType) 
	Dim strTmp  
	strTmp = ""  
	IF(strType ="s")THEN  
		strTmp = Replace(Trim(str),"'","&#39;") 
		strTmp = Replace(strTmp, CHR(39), "&#39;")
	ELSEIF(strType="i")THEN  
		IF(IsNumeric(str)=False)THEN str=False  
		strTmp = str  
	ELSE  
		strTmp = str  
	END IF  
	CheckStr= strTmp  
End Function

Function getHTTPPage(url) 
	IF(IsObjInstalled("Microsoft.XMLHTTP") = False)THEN
		Response.Write "<div align=center><div class=""info"">服务器不支持Microsoft.XMLHTTP组件</div></div>" 
		Err.Clear
		Response.End
	END IF
	On Error Resume Next
	Dim http 
	SET http=Server.CreateObject("Msxml2.XMLHTTP") 
	Http.open "GET",url,False 
	Http.send() 
	IF(Http.readystate<>4)THEN
		Exit Function 
	END IF 
	getHTTPPage=BytesToBSTR(Http.responseBody,"utf-8")
	SET http=NOTHING
	IF(Err.number<>0)THEN
		Response.Write "<div align=center><div class=""info"">获取文件内容出错</div></div>" 
		'Response.End
		Err.Clear
	END IF  
End Function

		
Function BytesToBstr(CodeBody,CodeSet)
	Dim objStream
	SET objStream = Server.CreateObject("adodb.stream")
	objStream.Type = 1
	objStream.Mode =3
	objStream.Open
	objStream.Write CodeBody
	objStream.Position = 0
	objStream.Type = 2
	objStream.Charset = CodeSet
	BytesToBstr = objStream.ReadText 
	objStream.Close
	SET objStream = NOTHING
End Function

'================================================
'作  用：检查组件是否已经安装
'参  数：strClassString ----组件名
'返回值：True  ----已经安装
'        False ----没有安装
'================================================
Function IsObjInstalled(objName)
	On Error Resume Next
	IsObjInstalled = False
	Err = 0
	Dim testObj
	SET testObj = Server.CreateObject(objName)
	IF(0 = Err)THEN IsObjInstalled = True
	SET testObj = NOTHING
	Err = 0
End Function

'================================================
'作  用		：替换字符串中的远程文件为本地文件并保存远程文件
'sHTML		: 要替换的字符串
'sSavePath	: 保存文件的路径
'sExt		: 执行替换的扩展名
'================================================
Function ReplaceRemoteUrl(sHTML, sSavePath, sExt)
	Dim s_Content
	s_Content = sHTML
	IF(IsObjInstalled("Microsoft.XMLHTTP") = False)THEN
		ReplaceRemoteUrl = s_Content
		Exit Function
	END IF
	
	IF(sSavePath = "")THEN sSavePath = "upload/"	'最后需要/
	IF(sExt = "")THEN sExt = "jpg|gif|bmp|png"
	Dim re, RemoteFile, RemoteFileurl, SaveFileName, SaveFileType
	SET re = new RegExp
	re.IgnoreCase  = True
	re.Global = True
	re.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}((\w)+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(" & sExt & ")))"
	SET RemoteFile = re.Execute(s_Content)
	IF(Err<>0)THEN
		Exit Function
	END IF 
	For Each RemoteFileurl in RemoteFile
		SaveFileType = Mid(RemoteFileurl, InstrRev(RemoteFileurl, ".") + 1)
		SaveFileName = sSavePath&Replace(Replace(Replace(Now(),"-",""),":","")," ","")&"."&SaveFileType
		Call SaveRemoteFile(SaveFileName, RemoteFileurl)
		s_Content = Replace(s_Content,RemoteFileurl,SaveFileName)
	Next
	ReplaceRemoteUrl = s_Content
End Function

'================================================
'作  用：保存远程的文件到本地
'参  数：LocalFileName ------ 本地文件名
'		 RemoteFileUrl ------ 远程文件URL
'返回值：True  ----成功
'        False ----失败
'================================================
Sub SaveRemoteFile(s_LocalFileName,s_RemoteFileUrl)
	Dim Ads, Retrieval, GetRemoteData
	On Error Resume Next
	SET Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
	With Retrieval
		.Open "Get", s_RemoteFileUrl, False, "", ""
		.Send
		GetRemoteData = .ResponseBody
	End With
	SET Retrieval = NOTHING
	SET Ads = Server.CreateObject("Adodb.Stream")
	With Ads
		.Type = 1
		.Open
		.Write GetRemoteData
		.SaveToFile Server.MapPath(s_LocalFileName), 2
		.Cancel()
		.Close()
	End With
	SET Ads=NOTHING
End Sub

Function RegExpText(strng,strStart,strEnd,n)
	Dim regEx,Match,Matches,RetStr
	SET regEx = New RegExp
	regEx.Pattern = strStart&"([\s\S]*?)"&strEnd
	regEx.IgnoreCase = True
	regEx.Global = True
	SET Matches = regEx.Execute(strng)
	For Each Match in Matches
		IF(n=1)THEN
			RetStr = RetStr & regEx.Replace(Match.Value,"$1") & "," 
		ELSE
			RetStr = RetStr & regEx.Replace(Match.Value,"$1")
		END IF 
	Next
	RegExpText = RetStr
	SET regEx=NOTHING
End Function

Function ReplaceRemoteImage(sHTML)
	Dim re, RemoteFile, RemoteFileurl
	SET re = new RegExp
	re.IgnoreCase  = True
	re.Global = True
	re.Pattern = "/newsfile/([\s\S]*?)"""
	SET RemoteFile = re.Execute(sHTML)
	IF(Err<>0)THEN
		Exit Function
	END IF 
	sHTML = re.Replace(sHTML,"http://edu.cnzz.cn/newsfile/$1""")
	ReplaceRemoteImage = sHTML
End Function

Sub Message(whe,strMessage)
	Response.Write("<script language=javascript>document.getElementById("""&whe&""").innerHTML="""&strMessage&""";</script>")
End Sub 

Function ReadTemplate(TemplateName)
    Dim objFSO,objMyFSO
    Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
    Set objMyFSO = objFSO.OpenTextFile(Server.MapPath(TemplateName),1,True)
    ReadTemplate = objMyFSO.ReadAll
    objMyFSO.Close
    Set objMyFSO = Nothing
    Set objFSO = Nothing
End Function

Sub makeHTML(strContent,strFileName,strPath)
    Dim objFSO,objMyFSO
    SET objFSO = Server.CreateObject("Scripting.FileSystemObject")
	IF(objFSO.FileExists(Server.MapPath(strPath & strFileName & ".html")))THEN
		objFSO.DeleteFile(Server.MapPath(strPath & strFileName & ".html")) 
	END IF
	SET objMyFSO=objFSO.CreateTextFile(Server.MapPath(strPath & strFileName & ".html")) 
	objMyFSO.Writeline(strContent) 
    objMyFSO.Close
	SET objMyFSO=NOTHING 
	SET objFSO=NOTHING
End Sub 
%>