⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 function.asp

📁 小说站源代码文件
💻 ASP
📖 第 1 页 / 共 4 页
字号:
🔍
1234 
	Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2

	Set Re = New Regexp 
	Re.IgnoreCase = True 
	Re.Global = True
	Re.Pattern ="<img.+?>"
	Set Matches =Re.Execute(ConStr) 
	For Each Match in Matches
		If TempStr<>"" then 
			TempStr=TempStr & "$Array$" & Match.Value
		Else
			TempStr=Match.Value
		End if
	Next
	If TempStr<>"" Then
		TempArray=Split(TempStr,"$Array$")
		TempStr=""
		For Tempi=0 To Ubound(TempArray)
			Re.Pattern ="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"
			Set Matches =Re.Execute(TempArray(Tempi)) 
			For Each Match in Matches
				If TempStr<>"" then 
					TempStr=TempStr & "$Array$" & Match.Value
				Else
					TempStr=Match.Value
				End if
			Next
		Next
	End if
	If TempStr<>"" Then
		Re.Pattern ="src\s*=\s*"
		TempStr=Re.Replace(TempStr,"")
	End If
	Set Matches=nothing
	Set Re=nothing
	If TempStr="" or IsNull(TempStr)=True Then
		ReplaceSaveRemoteFile=ConStr
		Exit function
	End if
	TempStr=Replace(TempStr,"""","")
	TempStr=Replace(TempStr,"'","")
	TempStr=Replace(TempStr," ","")
	Dim RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path
	DtNow=Now()
 '***********************************
	If SaveTf=True then
		SavePath=InstallPath&strChannelDir
			If CheckDir(InstallPath & strChannelDir)=False Then
				If Not CreateMultiFolder(InstallPath & strChannelDir) Then
				response.Write InstallPath & strChannelDir&"目录创建失败"
					SaveTf=False
				End If
			End If
	End If

	'去掉重复图片开始
	TempArray=Split(TempStr,"$Array$")
	TempStr=""
	For Tempi=0 To Ubound(TempArray)
		If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
			TempStr=TempStr & "$Array$" & TempArray(Tempi)
		End If
	Next
	TempStr=Right(TempStr,Len(TempStr)-7)
	TempArray=Split(TempStr,"$Array$")
	'去掉重复图片结束

	response.Write "<br>发现图片:<br>"&Replace(TempStr,"$Array$","<br>")

	'转换相对图片地址开始
	TempStr=""
	For Tempi=0 To Ubound(TempArray)
		TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
	Next
	TempStr=Right(TempStr,Len(TempStr)-7)
	TempStr=Replace(TempStr,Chr(0),"")
	TempArray2=Split(TempStr,"$Array$")
	TempStr=""
	'转换相对图片地址结束

	'图片替换/保存
	Set Re = New Regexp
	Re.IgnoreCase = True 
	Re.Global = True

	For Tempi=0 To Ubound(TempArray2)
'********************************
		RemoteFileUrl=TempArray2(Tempi)
		If RemoteFileUrl<>"$False$" And SaveTf=True Then'保存图片
			ArrSaveFileName = Split(RemoteFileurl,".")
		 strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型
			If strFileType="asp" or strFileType="asa" or strFileType="aspx" or strFileType="cer" or strFileType="cdx" or strFileType="exe" or strFileType="rar" or strFileType="zip" then
				UploadFiles=""
				ReplaceSaveRemoteFile=ConStr
				Exit Function
			End If

			Randomize
			RanNum=Int(900*Rnd)+100
		 strFileName = year(DtNow) & right("0" & month(DtNow),2) & right("0" & day(DtNow),2) & right("0" & hour(DtNow),2) & right("0" & minute(DtNow),2) & right("0" & second(DtNow),2) & ranNum & "." & strFileType
			Re.Pattern =TempArray(Tempi)
		 response.Write "<br>保存到本地地址:"&InstallPath & strChannelDir & strFileName
		 If SaveRemoteFile(InstallPath & strChannelDir & strFileName,RemoteFileUrl,TistUrl)=True Then
		 response.Write "<font color=blue>成功</font><br>"
				PathTemp=InstallPath & strChannelDir & strFileName
				ConStr=Re.Replace(ConStr,PathTemp)
				Re.Pattern=InstallPath&strChannelDir
				UploadFiles=UploadFiles & "|" & InstallPath & strChannelDir & strFileName
			Else
				PathTemp=RemoteFileUrl
				ConStr=Re.Replace(ConStr,PathTemp)
			End If
		ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存图片
			Re.Pattern =TempArray(Tempi)
			ConStr=Re.Replace(ConStr,RemoteFileUrl)
		End If
'********************************
	Next	
	Set Re=nothing
	ReplaceSaveRemoteFile=ConStr
End function

'==================================================
'函数名：ReplaceSwfFile
'作  用：解析动画路径
'参  数：ConStr ------ 要替换的字符串
'参  数: TistUrl------ 当前网页地址
'==================================================
Function ReplaceSwfFile(ConStr,TistUrl)
	If ConStr="$False$" or ConStr="" or TistUrl="" or TistUrl="$False$" Then
		ReplaceSwfFile=ConStr
		Exit Function
	End If
	Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2

	Set Re = New Regexp 
	Re.IgnoreCase = True 
	Re.Global = True
	Re.Pattern ="<object.+?[^\>]>"
	Set Matches =Re.Execute(ConStr) 
	For Each Match in Matches
		If TempStr<>"" then 
			TempStr=TempStr & "$Array$" & Match.Value
		Else
			TempStr=Match.Value
		End if
	Next
	If TempStr<>"" Then
		TempArray=Split(TempStr,"$Array$")
		TempStr=""
		For Tempi=0 To Ubound(TempArray)
			Re.Pattern ="value\s*=\s*.+?\.swf"
			Set Matches =Re.Execute(TempArray(Tempi)) 
			For Each Match in Matches
				If TempStr<>"" then 
					TempStr=TempStr & "$Array$" & Match.Value
				Else
					TempStr=Match.Value
				End if
			Next
		Next
	End if
	If TempStr<>"" Then
		Re.Pattern ="value\s*=\s*"
		TempStr=Re.Replace(TempStr,"")
	End If
	If TempStr="" or IsNull(TempStr)=True Then
		ReplaceSwfFile=ConStr
		Exit function
	End if
	TempStr=Replace(TempStr,"""","")
	TempStr=Replace(TempStr,"'","")
	TempStr=Replace(TempStr," ","")

	Set Matches=nothing
	Set Re=nothing

	'去掉重复文件开始
	TempArray=Split(TempStr,"$Array$")
	TempStr=""
	For Tempi=0 To Ubound(TempArray)
		If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
			TempStr=TempStr & "$Array$" & TempArray(Tempi)
		End If
	Next
	TempStr=Right(TempStr,Len(TempStr)-7)
	TempArray=Split(TempStr,"$Array$")
	'去掉重复文件结束

	'转换相对地址开始
	TempStr=""
	For Tempi=0 To Ubound(TempArray)
		TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
	Next
	TempStr=Right(TempStr,Len(TempStr)-7)
	TempStr=Replace(TempStr,Chr(0),"")
	TempArray2=Split(TempStr,"$Array$")
	TempStr=""
	'转换相对地址结束

	'替换
	Set Re = New Regexp
	Re.IgnoreCase = True 
	Re.Global = True
	For Tempi=0 To Ubound(TempArray2)
		RemoteFileUrl=TempArray2(Tempi)
		Re.Pattern =TempArray(Tempi)
		ConStr=Re.Replace(ConStr,RemoteFileUrl)
	Next	
	Set Re=nothing
	ReplaceSwfFile=ConStr
End function

'==================================================
'过程名：SaveRemoteFile
'作  用：保存远程的文件到本地
'参  数：LocalFileName ------ 本地文件名
'参  数：RemoteFileUrl ------ 远程文件URL
'参  数：Referer ------ 远程调用文件（对付防采集的，用内容页地址，没有防的留空）
'==================================================
Function SaveRemoteFile(LocalFileName,RemoteFileUrl,Referer)
	 SaveRemoteFile=True
	dim Ads,Retrieval,GetRemoteData
	Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
	With Retrieval
		.Open "Get", RemoteFileUrl, False, "", ""
		if Referer<>"" then .setRequestHeader "Referer",Referer
		On Error Resume Next
		if Err <> 0 then
			Err.Clear
			SaveRemoteFile=False
			Exit Function
		end if
		.Send
		  If .Readystate<>4 then
				SaveRemoteFile=False
				Exit Function
		  End If
		GetRemoteData = .ResponseBody
	End With
	Set Retrieval = Nothing
	Set Ads = Server.CreateObject("Adodb.Stream")
	With Ads
		.Type = 1
		.Open
		.Write GetRemoteData
		.SaveToFile server.MapPath(LocalFileName),2
		.Cancel()
		.Close()
	End With
	Set Ads=nothing
end Function 

'==================================================
'函数名：FpHtmlEnCode
'作  用：标题过滤
'参  数：fString ------字符串
'==================================================
Function FpHtmlEnCode(fString)
	If IsNull(fString)=False or fString<>"" or fString<>"$False$" Then
		 fString=nohtml(fString)
		 fString=FilterJS(fString)
		 fString = Replace(fString,"&nbsp;"," ")
		 fString = Replace(fString,"&quot;","")
		 fString = Replace(fString,"&#39;","")
		 fString = replace(fString, ">", "")
		 fString = replace(fString, "<", "")
		 fString = Replace(fString, CHR(9), " ")'&nbsp;
		 fString = Replace(fString, CHR(10), "")
		 fString = Replace(fString, CHR(13), "")
		 fString = Replace(fString, CHR(34), "")
		 fString = Replace(fString, CHR(32), " ")'space
		 fString = Replace(fString, CHR(39), "")
		 fString = Replace(fString, CHR(10) & CHR(10),"")
		 fString = Replace(fString, CHR(10)&CHR(13), "")
		 fString=Trim(fString)
		 FpHtmlEnCode=fString
	Else
		 FpHtmlEnCode="$False$"
	End If
End Function

'==================================================
'函数名：GetPaing
'作  用：获取分页
'==================================================
Function GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
If ConStr="$False$" or ConStr="" Or StartStr="" Or OverStr="" or IsNull(ConStr)=True or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
	GetPaing="$False$"
	Exit Function
End If

Dim Start,Over,ConTemp,TempStr
TempStr=LCase(ConStr)
StartStr=LCase(StartStr)
OverStr=LCase(OverStr)
Over=Instr(1,TempStr,OverStr)
If Over<=0 Then
	GetPaing="$False$"
	Exit Function
Else
	If IncluR=True Then
		Over=Over+Len(OverStr)
	End If
End If
TempStr=Mid(TempStr,1,Over)
Start=InstrRev(TempStr,StartStr)
If IncluL=False Then
	Start=Start+Len(StartStr)
End If

If Start<=0 Or Start>=Over Then
	GetPaing="$False$"
	Exit Function
End If
ConTemp=Mid(ConStr,Start,Over-Start)

ConTemp=Trim(ConTemp)
'ConTemp=Replace(ConTemp," ","")
ConTemp=Replace(ConTemp,",","")
ConTemp=Replace(ConTemp,"'","")
ConTemp=Replace(ConTemp,"""","")
ConTemp=Replace(ConTemp,">","")
ConTemp=Replace(ConTemp,"<","")
ConTemp=Replace(ConTemp,"&nbsp;","")
GetPaing=ConTemp
End Function


'***********************************************
'函数名：JoinChar
'作  用：向地址中加入 ? 或 &
'参  数：strUrl  ----网址
'返回值：加了 ? 或 & 的网址
'***********************************************
function JoinChar(strUrl)
	if strUrl="" then
		JoinChar=""
		exit function
	end if
	if InStr(strUrl,"?")<len(strUrl) then 
		if InStr(strUrl,"?")>1 then
			if InStr(strUrl,"&")<len(strUrl) then 
				JoinChar=strUrl & "&"
			else
				JoinChar=strUrl
			end if
		else
			JoinChar=strUrl & "?"
		end if
	else
		JoinChar=strUrl
	end if
end function


'**************************************************
1234

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -