function.asp

XXX档案美女图片站适合给图片广告的站长下载使用

<%
Function GetPageContent(Url) 
	Dim HTTPObj
	On Error Resume Next
	Set HTTPObj = Server.CreateObject("Microsoft.XMLHTTP") 
	With HTTPObj 
		.Open "Get", Url, False, "", "" 
		.Send 
	End With 
	if HTTPObj.Readystate <> 4 then
		Set HTTPObj = Nothing
		GetPageContent = False
		Exit Function
	end if
	GetPageContent = ResponseStrToStr(HTTPObj.ResponseBody)
	Set HTTPObj = Nothing
End Function

Function ResponseStrToStr(BodyStr)
	Dim ADOStreamObj
	Set ADOStreamObj = Server.CreateObject("ADODB.Stream")
	ADOStreamObj.Type = 1
	ADOStreamObj.Mode = 3
	ADOStreamObj.Open
	ADOStreamObj.Write BodyStr
	ADOStreamObj.Position = 0
	ADOStreamObj.Type = 2
	ADOStreamObj.Charset = "GB2312"
	ResponseStrToStr = ADOStreamObj.ReadText 
	ADOStreamObj.Close
	Set ADOStreamObj = Nothing
End Function

Function GetContent(Str,StartStr,LastStr,Flag)
	Dim SearchIndex
	On Error Resume Next
	if Instr(LCase(Str),LCase(StartStr)) > 0 then
		Select Case Flag
			Case 0
				GetContent = Right(Str,Len(Str) - Instr(LCase(Str),LCase(StartStr)) - Len(StartStr) + 1)
				SearchIndex = Instr(LCase(GetContent),LCase(LastStr))
				if SearchIndex <= 0 then
					GetContent = ""
				else
					GetContent = Left(GetContent,SearchIndex - 1)
				end if
			Case 1
				GetContent = Right(Str,Len(Str) - Instr(LCase(Str),LCase(StartStr)) + 1)
				GetContent = Left(GetContent,Instr(LCase(GetContent),LCase(LastStr)) + Len(LastStr) - 1)
			Case 2
				GetContent = Right(Str,Len(Str) - Instr(lcase(Str),LCase(StartStr))-Len(StartStr) + 1)
			Case else
				GetContent = ""
		End Select
	else
		GetContent = ""
	end if
	if Err.Number <> 0 then GetContent = ""
End Function

Function LoseHtml(ContentStr)
	Dim ClsTempLoseStr,regEx
	ClsTempLoseStr = Cstr(ContentStr)
	Set regEx = New RegExp
	regEx.Pattern = "<\/*[^<>]*>"
	regEx.IgnoreCase = True
	regEx.Global = True
	ClsTempLoseStr = regEx.Replace(ClsTempLoseStr,"")
	Set regEx = Nothing
	LoseHtml = ClsTempLoseStr
End function

Function ReplaceRemoteUrl(NewsContent,SaveFilePath)
	Dim re,RemoteFile,RemoteFileurl,SaveFileName,FileName,FileExtName
	Set re = New RegExp
	re.IgnoreCase = True
	re.Global=True
	're.Pattern = "<img\/*[^<>]*>"
	re.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}((\w)+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(gif|jpg|png|bmp)))"
	Set RemoteFile = re.Execute(NewsContent)
	Set re = Nothing
	For Each RemoteFileurl in RemoteFile
		SaveFileName = Mid(RemoteFileurl,InstrRev(RemoteFileurl,"/")+1)
		FileExtName = Mid(SaveFileName,InstrRev(SaveFileName,".")+1)
		Call SaveRemoteFile(SaveImagePath & "/" & SaveFileName,RemoteFileurl)
		NewsContent = Replace(NewsContent,RemoteFileurl,SaveImagePath & "/" & SaveFileName)
	Next
	ReplaceRemoteUrl = NewsContent
End Function

Sub SaveRemoteFile(LocalFileName,RemoteFileUrl)
	Dim StreamObj,Retrieval,GetRemoteData
	Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
	With Retrieval
		.Open "Get", RemoteFileUrl, False, "", ""
		.Send
		GetRemoteData = .ResponseBody
	End With
	Set Retrieval = Nothing
	Set StreamObj = Server.CreateObject("Adodb.Stream")
	With StreamObj
		.Type = 1
		.Open
		.Write GetRemoteData
		.SaveToFile Server.MapPath(LocalFileName),2
		.Cancel()
		.Close()
	End With
	Set StreamObj = Nothing
End Sub

Function GetRandomID18()
	Dim TempYear,TempMonth,TempDay,TempHour,TempMinute,TempSecond,RandomFigure
	Dim TempStr,NowTime
	NowTime = Now()
	TempYear =  Right(CStr(Year(NowTime)),2)
	TempMonth =  CStr(Month(NowTime))
	if Len(TempMonth) = 1 then
		TempHour = "0" & TempMonth
	end if
	TempDay =  CStr(Day(NowTime))
	if Len(TempDay) = 1 then
		TempHour = "0" & TempDay
	end if
	TempHour = CStr(Hour(NowTime))
	if Len(TempHour) = 1 then
		TempHour = "0" & TempHour
	end if
	TempMinute = CStr(Minute(NowTime))
	if Len(TempMinute) = 1 then
		TempMinute = "0" & TempMinute
	end if
	TempSecond = CStr(Second(NowTime))
	if Len(TempSecond) = 1 then
		TempSecond = "0" & TempSecond
	end if
	Randomize 
	RandomFigure = CStr(Int((99999 * Rnd) + 1))
	GetRandomID18 = TempYear & TempMonth & TempDay & TempHour & TempMinute & TempSecond & RandomFigure
End Function

Function FormatUrl(NewsLinkStr,SiteUrl)
	NewsLinkStr = Replace(Replace(NewsLinkStr,"'",""),"""","")
	if InStr(NewsLinkStr,"http://") = 0 then
		if InStrRev(NewsLinkStr,"..") = 0 then
			FormatUrl = SiteUrl & NewsLinkStr
		else
			FormatUrl = SiteUrl & Mid(NewsLinkStr,InStrRev(NewsLinkStr,"..")+2)
		end if
	else
		FormatUrl = NewsLinkStr
	end if
End Function
%>