一切福田，不離方寸，從心而覓，感無不通。

利用404特性同步文件(ASP版)

很久之前写的了，今天分享出来~

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
<%
Dim re_url,mainUrl,fso
mainUrl="http://localhost:81"
On Error Resume Next
Set fso=Server.CreateObject("Scripting.FileSystemObject")
Set Retrieval = Server.CreateObject("MSXML2.ServerXMLHTTP")
'获取404地址
If Instr(Request.ServerVariables("HTTP_HOST"),":") > 0 Then
re_url = Replace(Lcase(Request.ServerVariables("QUERY_STRING")),"404;http://"&Request.ServerVariables("HTTP_HOST"),"")
Else
re_url = Replace(Lcase(Request.ServerVariables("QUERY_STRING")),"404;http://"&Request.ServerVariables("HTTP_HOST")&":"&Request.ServerVariables("SERVER_PORT"),"")
End If
 
'只抓取member中的文件
If InStr(re_url,"/member")=0 Then Server.Transfer("/404.html")
If CheckURL(mainUrl&re_url) Then
Call SaveGetFile(re_url,re_url)
Else
'Response.Write(mainUrl&re_url)
Server.Transfer("/404.html")
Response.End
End If
Rem 检测资源是否存在
Function CheckURL(byval A_strUrl)
Retrieval.Open "HEAD", A_strUrl, False
Retrieval.Send()
CheckURL = (Retrieval.Status = 200)
End Function
 
Rem 抓取并保存资源
Function SaveGetFile(RemoteFileUrl,SaveFilePaths)
Dim Ads,GetRemoteData
RemoteFileUrl=ReplaceTest("//+",RemoteFileUrl,"/")
RemoteFileUrlU = Split(RemoteFileUrl, "/")
If InStr(RemoteFileUrlU(UBound(RemoteFileUrlU)),".")=0 Then Server.Transfer("/404.html"):Response.End
' Dim arrFType
' arrFType=Split(RemoteFileUrlU(UBound(RemoteFileUrlU)),".")
' '只抓取静态页面和图片
' Select Case LCase(arrFType(UBound(arrFType)))
' Case "html":
' Case "htm" :
' Case "jpg" :
' Case "jpeg":
' Case "bmp" :
' Case "gif" :
' Case "png":
' Case Else:
' 'Response.Write("2")
' Server.Transfer("/404.html")
' Response.End
' End Select
 
Dim tPath:tPath=""
'文件夹操作
For i=1 To Ubound(RemoteFileUrlU) Step 1
If i<>Ubound(RemoteFileUrlU) Then
If(Not IsFolder(tPath&RemoteFileUrlU(i)))Then
If i=1 Then
Call CreateFolder(RemoteFileUrlU(i))
tPath=tPath&RemoteFileUrlU(i)&"/"
Else
Call CreateFolder(tPath&RemoteFileUrlU(i))
tPath=tPath&RemoteFileUrlU(i)&"/"
End If
Else
tPath=tPath&RemoteFileUrlU(i)&"/"
End If
End If
Next
'Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "GET", mainUrl&RemoteFileUrl, False, "", ""
.Send
GetRemoteData = .ResponseBody
End With
 
SaveFileName = SaveFilePaths
 
Set Retrieval = Nothing
Set Ads = Server.CreateObject("Adodb.Stream")
 
With Ads
.Type = 1
.Open
.Write GetRemoteData
.SaveToFile Server.MapPath(SaveFileName),2
.Cancel
.Close
End With
Set Ads = Nothing
SaveGetFile = SaveFileName
End Function
Function IsFolder(Folder)
If FSO.FolderExists(Server.MapPath(Folder)) Then  
IsFolder = True
Else
IsFolder = False
End If
End Function
Function CreateFolder(fldr)
Dim f
Set f = FSO.CreateFolder(Server.MapPath(fldr))
CreateFolder = f.Path
Set f=nothing
End Function
Function ts(str)
Response.Write(str)
Response.End
End Function
 
Function ReplaceTest(patrn,str1,replStr)
  Dim regEx
  Set regEx = New RegExp
  regEx.Pattern = patrn
  regEx.IgnoreCase = True
  regEx.Global = True
  ReplaceTest = regEx.Replace(str1,replStr)
End Function
If Err Then
Err.Clear
Server.Transfer("/404.html")
Response.End
End If
'转向抓取过来的资源
'Response.Write("3")
Server.Transfer(re_url)
Response.End
%>

 

Copyright © 2024 Longsheng All rights reserved