📄 system_gather.asp
字号:
<!--#include file="Cook.asp"-->
<%
'================================
'采集数据库操作
Dim UploadFiles
Dim Url,Sign,Sign1,gI,ga
Server.ScriptTimeout=9999
Sign = "ф§ф"
Sign1 = "Ф§Ф"
'重置内容地址
Function GetUrl(Url,Str)
If Str = "" Or IsNull(Url) Or Str = "" Or IsNull(Str) Then Exit Function
If Instr(Str,"|") > 0 Then
If Int(Split(Str,"|")(0)) = 1 Then Url = WRMPS.GetReplace(Split(Str,"|")(1),"{$Url}",Url)
End If
GetUrl = Url
End Function
'标签过滤
Function LeachFilter(Str,Leach)
If Instr(Leach,"|iframe|") > 0 Then Str=ScriptHtml(Str,"ifrAme",1)
If Instr(Leach,"|object|") > 0 Then Str=ScriptHtml(Str,"Object",2)
If Instr(Leach,"|script|") > 0 Then Str=ScriptHtml(Str,"Script",2)
If Instr(Leach,"|div|") > 0 Then Str=ScriptHtml(Str,"Div",3)
If Instr(Leach,"|table|") > 0 Then Str=ScriptHtml(Str,"table",3)
If Instr(Leach,"|tr|") > 0 Then Str=ScriptHtml(Str,"tr",3)
If Instr(Leach,"|td|") > 0 Then Str=ScriptHtml(Str,"td",3)
If Instr(Leach,"|span|") > 0 Then Str=ScriptHtml(Str,"Span",3)
If Instr(Leach,"|img|") > 0 Then Str=ScriptHtml(Str,"Img",3)
If Instr(Leach,"|font|") > 0 Then Str=ScriptHtml(Str,"Font",3)
If Instr(Leach,"|a|") > 0 Then Str=ScriptHtml(Str,"A",3)
If Instr(Leach,"|html|") > 0 Then Str=WRMPS.LeachHTML(Str)
LeachFilter = Str
End Function
Function ScriptHtml(Byval ConStr,TagName,FType)
gRe.IgnoReCase =true
gRe.Global=True
Select Case FType
Case 1
gRe.Pattern="<" & TagName & "([^>])*>"
ConStr=gRe.Replace(ConStr,"")
Case 2
gRe.Pattern="<" & TagName & "([^>])*>.*?</" & TagName & "([^>])*>"
ConStr=gRe.Replace(ConStr,"")
Case 3
gRe.Pattern="<" & TagName & "([^>])*>"
ConStr=gRe.Replace(ConStr,"")
gRe.Pattern="</" & TagName & "([^>])*>"
ConStr=gRe.Replace(ConStr,"")
End Select
ScriptHtml=ConStr
End Function
'数据过滤
Function LeachData(gStr,gType,gStr1,gStr2)
Dim gLeachTemp
gLeachTemp = ""
Select Case gType
Case 0 '简单替换
LeachData = WRMPS.GetReplace(gStr,gStr1,gStr2)
Case 1 '高级过滤
gLeachTemp = Split(gStr1,Sign)(0) & HCode(gStr,Split(gStr1,Sign)(0),Split(gStr1,Sign)(1)) & Split(gStr1,Sign)(1)
LeachData = WRMPS.GetReplace(gStr,gLeachTemp,gStr2)
End Select
End Function
'字符替换
Function LeachStr(Str,Leach)
If IsNUll(Leach) Or Leach = "" Then LeachStr = Str:Exit Function
If Instr(Leach,vbCrLf) > 0 Then
Leach = Split(Leach,vbCrLf)
For gI = 0 To Ubound(Leach)
If Leach(gI) <> "" Then
Str = WRMPS.GetReplace(Str,Split(Leach(gI),"|")(0),Split(Leach(gI),"|")(1))
End If
Next
Else
If Instr(Leach,"|") > 0 Then Str = WRMPS.GetReplace(Str,Split(Leach,"|")(0),Split(Leach,"|")(1))
End If
LeachStr = Str
End Function
'==================================================
'函数名：FpHtmlEnCode
'作 用：标题过滤
'==================================================
Function FpHtmlEnCode(fString)
If IsNull(fString)=False or fString<>"" Then
fString=WRMPS.LeachHTML(fString)
fString=FilterJS(fString)
fString = Replace(fString," "," ")
fString = Replace(fString,""","")
fString = Replace(fString,"'","")
fString = Replace(fString, ">", "")
fString = Replace(fString, "<", "")
fString = Replace(fString, CHR(9), " ")'
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=""
End If
End Function
Function FilterJS(byval v)
if isnull(v) or trim(v)="" then
FilterJS=""
exit function
end if
dim t
dim ReContent
gRe.IgnoReCase =true
gRe.Global=True
gRe.Pattern="(javascript)"
t=gRe.Replace(v,"javascript")
gRe.Pattern="(jscript:)"
t=gRe.Replace(t,"jscript:")
gRe.Pattern="(js:)"
t=gRe.Replace(t,"js:")
gRe.Pattern="(about:)"
t=gRe.Replace(t,"about:")
gRe.Pattern="(file:)"
t=gRe.Replace(t,"file:")
gRe.Pattern="(document.cookie)"
t=gRe.Replace(t,"documents.cookie")
gRe.Pattern="(vbscript:)"
t=gRe.Replace(t,"vbscript:")
gRe.Pattern="(vbs:)"
t=gRe.Replace(t,"vbs:")
FilterJS=t
End Function
'===============================================
'函数名：GetHttpPage
'作 用：获取网页源码
'参 数：HttpUrl 网页地址,Cset 编码
'===============================================
Function GetHttpPage(ByVal URL, ByVal Cset)
Dim BlockStartTime
On Error Resume Next
If IsNull(URL)=True Or Len(URL)<18 Or URL="" Then
GetHttpPage=""
Exit Function
End If
BlockStartTime = Timer()
Http.open "GET",URL,False
Http.Send()
'循环等待数据接收
Dim temp,BlockTimeout
BlockTimeout = 64
While (http.ReadyState <> 4)
' 判断是否块超时
temp = Timer() - BlockStartTime
If (temp > BlockTimeout) Then
http.abort
GetHttpPage=""
Exit function
Response.End
End If
http.waitForResponse 10000'等待1000毫秒
Wend
If Http.Readystate<>4 then
GetHttpPage=""
Exit function
End if
GetHTTPPage=bytesToBSTR(Http.ResponseBody,Cset)
If Err.number<>0 then
If IsNull(URL)=True Or Len(URL)<18 Or URL="" Then
GetHttpPage=""
Exit Function
End If
Err.Clear
End If
End Function
'===============================================
'函数名：BytesToBstr
'作 用：将获取的源码转换为中文
'参 数：Body 要转换的变量
'参 数：Cset 要转换的类型
'===============================================
Function BytesToBstr(Body,Cset)
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
End Function
'列表截取
Function ListCode(Str,CodeB,CodeE,Ty)
Dim ReplaceStr,T_Str,Matches,Match
ReplaceStr = ""
GRegE.Pattern="("&CodeB&")([\s\S]+?)("&CodeE&")"
GRegE.IgnoReCase=True
GRegE.Global=True
Set Matches=GRegE.Execute(Str)
For Each Match in Matches
T_Str = GRegE.Replace(Match.Value,"$2")
If ReplaceStr = "" Then
ReplaceStr = T_Str
Else
If Instr("§" & ReplaceStr,"§" & T_Str) = 0 Then
Select Case Ty
Case 0
ReplaceStr = ReplaceStr & "§" & T_Str
Case 1
ReplaceStr = T_Str & "§" & ReplaceStr '倒
End Select
End If
End If
Next
Set Matches=Nothing
ListCode = ReplaceStr
End Function
'信息截取
Function HCode(Str,B,E)
If Str="" or IsNull(Str)=True Then HCode="":Exit Function
If B="" or IsNull(B)=True Or E="" or IsNull(E)=True Then HCode=Str:Exit Function
GRegE.Pattern="(\"&B&")([\s\S]+?)(\"&E&")"
Set Matchess = GRegE.Execute(Str)
For Each Matchs in Matchess
HCode = GRegE.Replace(Matchs.Value,"$2")
Next
End Function
'获取/保存远程图片
'gStr 原字符串,gUpFolder 文件保存目录 true/false,gSave是否保存远程文件,gUrl目标URL,gWatermark 1添加水印 0不添加 gCReThumb生不生成缩略图 1生成 0不生成
Function ReplaceSaveRemoteFile(gStr,gUpFolder,gSave,gUrl,gWatermark,gCThumb)
If gStr = "" Or gUpFolder = "" Then ReplaceSaveRemoteFile = gStr:Exit Function
UploadFiles = ""
'提取图片列表
Dim T_Str,T_Str2,T_Str3,Matches,Match,Tempi,TempArray,TempArray2
Dim SavePath,sSavePath,RemoteFileUrl,strFileType,ArrSaveFileName,RanNum,strFileName,PathTemp
gRe.IgnoReCase = True
gRe.Global = True
gRe.Pattern ="<img.+?[^\>]>"
Set Matches =gRe.Execute(gStr)
For Each Match in Matches
If T_Str<>"" then
T_Str=T_Str & "§§§" & Match.Value
Else
T_Str=Match.Value
End if
Next
If T_Str<>"" Then
TempArray=Split(T_Str,"§§§")
T_Str=""
For Tempi=0 To Ubound(TempArray)
gRe.Pattern ="src\s*=\s*.+?\.("&WR_Gather(5)&")"
Set Matches =gRe.Execute(TempArray(Tempi))
For Each Match in Matches
If T_Str<>"" then
T_Str=T_Str & "§§§" & Match.Value
Else
T_Str=Match.Value
End if
Next
Next
gRe.Pattern ="src\s*=\s*"
T_Str=gRe.Replace(T_Str,"")
End If
Set Matches=nothing
If T_Str="" or IsNull(T_Str)=True Then
ReplaceSaveRemoteFile=gStr
Exit function
End if
T_Str=Replace(T_Str,"""","")
T_Str=Replace(T_Str,"'","")
T_Str=Replace(T_Str," ","")
'提取图片列表结束
'如果保存远程文件则建立保存目录
If gSave=True then
SavePath = gUpFolder
Response.write " 正在下载图片并且保存至：" & savepath & "<br>"
sSavePath = SavePath&"S/"
Call WRMPS.FsoBegin()
If Int(WR_UpLoad(20)) > 0 Then '缩略图
Call WRMPS.CReFolder(SavePath&"S/")
Else
Call WRMPS.CReFolder(SavePath)
End If
Call WRMPS.FsoEnd()
End If
'建立上传目录结束
'去掉重复图片开始
TempArray=Split(T_Str,"§§§")
T_Str=""
For Tempi=0 To Ubound(TempArray)
If Instr(Lcase(T_Str),Lcase(TempArray(Tempi)))<1 Then
T_Str=T_Str & "§§§" & TempArray(Tempi)
End If
Next
T_Str=Right(T_Str,Len(T_Str)-3)
TempArray=Split(T_Str,"§§§")
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -