📄 admin_saveremoteimages.asp
字号:
<%
Class SaveRemoteImages
Private SRI_Error, SRI_ImagesList, SRI_Flag, SRI_SubFolder
Private SRI_CreateWatermark, SRI_CreateThumb
Private Sub Class_Initialize
SRI_Error = 0
SRI_ImagesList = ""
SRI_Flag = False
SRI_CreateWatermark = False
SRI_CreateThumb = False
SRI_SubFolder = Year(date()) & Right("0"& Month(date()), 2)
End Sub
Private Sub Class_Terminate
SRI_Error = 0
End Sub
Public Property Get GetImagesList() '取得下载后的图片文件
GetImagesList = SRI_ImagesList
End Property
Public Property Get GetSRI_Flag() '是否有系统外部的图片
GetSRI_Flag = SRI_Flag
End Property
Public Property Let SetCreateWatermark(EnableWatermark)
If Trim(LCase(TypeName(EnableWatermark))) = "boolean" Then
SRI_CreateWatermark = EnableWatermark
End If
End Property
Public Property Let SetCreateThumb(EnableCreateThumb)
If Trim(LCase(TypeName(EnableCreateThumb))) = "boolean" Then
SRI_CreateThumb = EnableCreateThumb
End If
End Property
Public Function AutoSave(SRI_Content, SRI_UploadDir)
On Error Resume Next
SRI_Flag = False
Dim objRegExp, Matches, Result, i, Match
Dim ArrImages, AllImages, NewImages, NewFileName, NewImagesTrue
Dim ArrNewImages, ArrAllImages, ArrFailImages
Dim JpegWatermark, FileTruePath, TempFlag
Dim ThumbFileName, JpegErrorCode
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<IMG.+?>"
Result = ""
Set Matches = objRegExp.Execute(Trim(SRI_Content))
For Each Match in Matches
Result = Result & GetImages(Match.Value)
Next
If Trim(Result)="" Then
SRI_Flag = False
AutoSave = SRI_Content
Exit Function
Else
SRI_Flag = True
End If
ArrImages = Split(Result,"|")
AllImages = ""
NewImages = ""
ArrFailImages = ""
Response.Write "<p><span class='blueText'><strong>内容包含系统外部图片，正在保存远程图片…… 在此过程中不要刷新！！！</strong></span></p>"
Response.Flush()
Dim ImageCount,FailCount,SuccCount
ImageCount = 0
FailCount = 0
SuccCount = 0
Call CreateFolder(Server.MapPath(SRI_UploadDir), "\"& SRI_SubFolder) '检查并创建保存文件路径
For i=1 To Ubound(ArrImages)
If ArrImages(i)<>"" And Instr(AllImages,ArrImages(i))<1 Then '看这个图片是否已经下载过
NewFileName = Cstr(GetRndNumber & Mid(ArrImages(i),InstrRev(ArrImages(i),".")))
Response.Write "<p><span class='redText'><strong>正在保存远程图片 "& (ImageCount+1) &"：</strong></span><span class='blueText'>"& ArrImages(i) &" …… </span> "
Response.Flush()
Call SaveImage(ArrImages(i), SRI_UploadDir & SRI_SubFolder &"/"& NewFileName)
If SRI_Error = 0 Then
Response.Write "成功！</p>"
SuccCount = SuccCount + 1
AllImages = AllImages &"|"& ArrImages(i) '把保存下来的图片的地址串回起来，以确定要替换的地址
NewImages = NewImages &"|"& SRI_SubFolder &"/"& NewFileName '把本地的地址串回起来
NewImagesTrue = NewImagesTrue &"|"& SRI_SubFolder &"/"& NewFileName
JpegErrorCode = 0
TempFlag = False
FileTruePath = Server.MapPath(SRI_UploadDir & SRI_SubFolder &"/"& NewFileName)
If SRI_CreateWatermark = True Then '添加水印
Set JpegWatermark = New ClassJpeg
If JpegWatermark.ErrorCode = 0 Then
JpegWatermark.CreateWatermark FileTruePath
If SRI_CreateThumb = True Then
JpegWatermark.CreateThumb FileTruePath, 1
ThumbFileName = SRI_SubFolder &"/"& JpegWatermark.ThumbFileName
JpegErrorCode = JpegWatermark.ErrorCode
TempFlag = True
End If
End If
Set JpegWatermark = Nothing
End If
If SRI_CreateThumb = True And TempFlag = False Then '产生缩略图
Dim JpegThumb
Set JpegThumb = New ClassJpeg
JpegThumb.CreateThumb FileTruePath, 1
ThumbFileName = SRI_SubFolder &"/"& JpegThumb.ThumbFileName
JpegErrorCode = JpegThumb.ErrorCode
Set JpegThumb = Nothing
End If
If SRI_CreateThumb = True And JpegErrorCode = 0 Then '把缩略图的地址串回起来
NewImagesTrue = NewImagesTrue &"|"& ThumbFileName
End If
ElseIf SRI_Error = 2 Then
Response.Write "<span class='redText'>失败！</span>，保存路径错误</p>"
FailCount = FailCount + 1
ArrFailImages = ArrFailImages &"|"& ArrImages(i)
Else
Response.Write "<span class='redText'>失败！</span></p>"
FailCount = FailCount + 1
ArrFailImages = ArrFailImages &"|"& ArrImages(i)
End If
SRI_Error = 0
Response.Write "<script>scrollBy(0,document.body.scrollHeight)</script>"
Response.Flush()
ImageCount = ImageCount + 1
End If
Next
Response.Write "<p>"
Response.Write "<span class='blueText'>成功保存的图片：<span class='redText'><strong>"& SuccCount &"</strong></span> 张</span>"
Response.Write "<script>scrollBy(0,document.body.scrollHeight)</script>"
Response.Flush()
If Trim(ArrFailImages) <> "" Then
Response.Write "<br><span class='redText'>保存失败的图片：<strong><span class='redText'>"& FailCount &"</span></strong> 张</span><br>"
Response.Flush()
ArrFailImages = Split(ArrFailImages,"|")
For i=1 To Ubound(ArrFailImages)
Response.Write "  <span class='blueText'><strong>"& i &"</strong>："& ArrFailImages(i) &"</span><br>"
Response.Write "<script>scrollBy(0,document.body.scrollHeight)</script>"
Response.Flush()
Next
End If
Response.Write "</p> <br><p> </p>"
Response.Flush()
Response.Write "<script>scrollBy(0,document.body.scrollHeight)</script>"
Response.Flush()
ArrAllImages = Split(AllImages,"|")
ArrNewImages = Split(NewImages,"|")
Result = Trim(SRI_Content)
For i=1 To Ubound(ArrNewImages) '执行循环替换原来的地址
Result = Replace(Result,ArrAllImages(i),SRI_UploadDir & ArrNewImages(i))
Next
AutoSave = Result
If Trim(NewImagesTrue) <> "" Then NewImagesTrue = Right(NewImagesTrue, Len(NewImagesTrue)-1)
SRI_ImagesList = NewImagesTrue
End Function
Private Function GetImages(ByVal str)
GetImages = ""
Dim objRegExp,Matchs,TempMatch, Host, Temp
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "http://.+?"""
Host = lCase(Request.ServerVariables("HTTP_HOST"))
Set TempMatch = objRegExp.Execute(str)
For Each Matchs in TempMatch
Temp = lCase(Right(Matchs.Value, Len(Matchs.Value)-7))
If Left(Temp, Instr(Temp, "/")-1) <> Host Then
GetImages = GetImages &"|"& Left(Matchs.Value, Len(Matchs.Value)-1)
End If
Next
End Function
Private Sub SaveImage(ByVal URLString, ByVal FileNameString)
On Error Resume Next
Dim ObjStream,ImageData, OString
ImageData = GetRemoteData(Trim(URLString))
If SRI_Error <> 0 Then Exit Sub
OString = "ADODB." & "Stream"
Set ObjStream = Server.CreateObject(OString)
ObjStream.Type =1
ObjStream.Open
ObjStream.write ImageData
ObjStream.SaveToFile Server.Mappath(FileNameString),2
If Err Then
Err.Clear
SRI_Error = 2
End If
ObjStream.Close()
Set ObjStream = Nothing
End Sub
Private Function GetRemoteData(url)
On Error Resume Next
Dim Http, OString
OString = "MSXML2.XMLHTTP"
Set Http = Server.CreateObject(OString)
Http.Open "GET",url,False
Http.send()
If Http.readystate<>4 Then
SRI_Error = 1
Exit Function
Else
SRI_Error = 0
End If
If Http.status<>200 Then
SRI_Error = 1
Exit Function
Else
SRI_Error = 0
End If
GetRemoteData = Http.responseBody
Set Http = Nothing
If Err.Number<>0 Then
SRI_Error = 1
Err.Clear
End If
End Function
Private Sub CreateFolder(ByVal StrPath, ByVal NewFolder)
Dim FSO
Set FSO = Server.CreateObject(Object_FSO)
IF NOT FSO.FolderExists(StrPath & NewFolder) Then
FSO.CreateFolder(StrPath & NewFolder)
End If
Set FSO = Nothing
End Sub
Private Function GetRndNumber()
Dim RndN, DtNow
Randomize
DtNow = Now()
RndN=int(9999*rnd)+1000
GetRndNumber = 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) & RndN
End Function
End Class
%>⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -