📄 system_gather.asp
字号:
T_Str=""
'去掉重复图片结束
'转换相对图片地址开始
For Tempi=0 To Ubound(TempArray)
T_Str=T_Str & "§§§" & DefiniteUrl(TempArray(Tempi),gUrl)
Next
T_Str=Right(T_Str,Len(T_Str)-3)
T_Str=Replace(T_Str,Chr(0),"")
TempArray2=Split(T_Str,"§§§")
'T_Str=""
'转换相对图片地址结束
'图片替换/保存
gRe.IgnoReCase = True
gRe.Global = True
For Tempi=0 To Ubound(TempArray2)
RemoteFileUrl=TempArray2(Tempi)
If RemoteFileUrl<>"$$$" And gSave=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=gStr
Exit Function
End If
Randomize
RanNum=Int(9000*Rnd)+1000
strFileName = year(Now()) & right("0" & month(Now()),2) & right("0" & day(Now()),2) & right("0" & hour(Now()),2) & right("0" & minute(Now()),2) & right("0" & second(Now()),2) & ranNum & "." & strFileType
gRe.Pattern =TempArray(Tempi)
If SaveRemoteFile(SavePath & strFileName,RemoteFileUrl)=True Then
PathTemp=SavePath & strFileName
gStr=gRe.Replace(gStr,PathTemp)
gRe.Pattern= gUpFolder
UploadFiles=UploadFiles & "|" & gRe.Replace(SavePath & strFileName,"")
Response.Flush()
Response.write " 保存地址：" & PathTemp & "<br>"
gStr=WRMPS.GetReplace(gStr,RemoteFileUrl,SavePath & strFileName) '替换远程地址
If Int(WR_UpLoad(20)) > 0 Then If Tempi = 0 and Int(gCThumb) > 0 Then Call CReateThumbs(PathTemp,sSavePath & strFileName)
If Int(WR_UpLoad(25)) > 0 Then If Int(gWatermark) > 0 Then Call AddWaterMark(PathTemp)'水印
Else
PathTemp=RemoteFileUrl
gStr=gRe.Replace(gStr,PathTemp)
End If
ElseIf RemoteFileurl<>"$$$" and gSave=False Then'不保存图片
gRe.Pattern =TempArray(Tempi)
gStr=gRe.Replace(gStr,RemoteFileUrl)
UploadFiles=UploadFiles & "|" & RemoteFileUrl
End If
Next
'图片替换/保存结束
'整理下载列表
If UploadFiles<>"" Then
UploadFiles = Right(UploadFiles,Len(UploadFiles)-1)
End If
ReplaceSaveRemoteFile = gStr
End Function
'==================================================
'过程名：SaveRemoteFile
'作 用：保存远程的文件到本地
'参 数：LocalFileName ------ 本地文件名
'参 数：RemoteFileUrl ------ 远程文件URL
'==================================================
Function SaveRemoteFile(LocalFileName,RemoteFileUrl)
SaveRemoteFile=True
dim Ads,Retrieval,GetRemoteData
On Error Resume Next
Set Retrieval = Server.CReateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "Get", RemoteFileUrl, False, "", ""
.Send
If .Readystate<>4 or .Status > 300 then
SaveRemoteFile=False
Exit Function
End If
GetRemoteData = .ResponseBody
End With
Set Retrieval = Nothing
If Round(LenB(GetRemoteData)/1024) > WR_Gather(6) Then SaveRemoteFile=False:Exit Function
Response.Write " ·图片大小："&(Round(LenB(GetRemoteData)/1024)) & "KB "
Set Ads = Server.CReateObject("Adodb.StReam")
With Ads
.Type = 1
.Open
.Write GetRemoteData
.SaveToFile server.MapPath(LocalFileName),2
.Cancel()
.Close()
End With
If Err.number<>0 then
SaveRemoteFile = False
Exit Function
Err.Clear
End If
Set Ads=nothing
End Function
'==================================================
'函数名：DefiniteUrl
'作 用：将相对地址转换为绝对地址
'参 数：PrimitiveUrl ------要转换的相对地址
'参 数：ConsultUrl ------当前网页地址
'==================================================
Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
If PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$$$" or ConsultUrl="$$$" Then
DefiniteUrl="$$$"
Exit Function
End If
If Left(Lcase(ConsultUrl),7)<>"http://" Then
ConsultUrl= "http://" & ConsultUrl
End If
ConsultUrl=Replace(ConsultUrl,"\","/")
ConsultUrl=Replace(ConsultUrl,"://",":\\")
PrimitiveUrl=Replace(PrimitiveUrl,"\","/")
If Right(ConsultUrl,1)<>"/" Then
If Instr(ConsultUrl,"/")>0 Then
If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then
Else
ConsultUrl=ConsultUrl & "/"
End If
Else
ConsultUrl=ConsultUrl & "/"
End If
End If
ConArray=Split(ConsultUrl,"/")
If Left(LCase(PrimitiveUrl),7) = "http://" then
DefiniteUrl=Replace(PrimitiveUrl,"://",":\\")
ElseIf Left(PrimitiveUrl,1) = "/" Then
DefiniteUrl=ConArray(0) & PrimitiveUrl
ElseIf Left(PrimitiveUrl,2)="./" Then
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)
If Right(ConsultUrl,1)="/" Then
DefiniteUrl=ConsultUrl & PrimitiveUrl
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
End If
ElseIf Left(PrimitiveUrl,3)="../" then
Do While Left(PrimitiveUrl,3)="../"
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Loop
For Ci=0 to (Ubound(ConArray)-1-Pi)
If DefiniteUrl<>"" Then
DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
Else
DefiniteUrl=ConArray(Ci)
End If
Next
DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl
Else
If Instr(PrimitiveUrl,"/")>0 Then
PriArray=Split(PrimitiveUrl,"/")
If Instr(PriArray(0),".")>0 Then
If Right(PrimitiveUrl,1)="/" Then
DefiniteUrl="http:\\" & PrimitiveUrl
Else
If Instr(PriArray(Ubound(PriArray)-1),".")>0 Then
DefiniteUrl="http:\\" & PrimitiveUrl
Else
DefiniteUrl="http:\\" & PrimitiveUrl & "/"
End If
End If
Else
If Right(ConsultUrl,1)="/" Then
DefiniteUrl=ConsultUrl & PrimitiveUrl
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
End If
End If
Else
If Instr(PrimitiveUrl,".")>0 Then
If Right(ConsultUrl,1)="/" Then
If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl),3)="org" Then
DefiniteUrl="http:\\" & PrimitiveUrl & "/"
Else
DefiniteUrl=ConsultUrl & PrimitiveUrl
End If
Else
If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl),3)="org" Then
DefiniteUrl="http:\\" & PrimitiveUrl & "/"
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl
End If
End If
Else
If Right(ConsultUrl,1)="/" Then
DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"
End If
End If
End If
End If
If Left(DefiniteUrl,1)="/" then
DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
End if
If DefiniteUrl<>"" Then
DefiniteUrl=Replace(DefiniteUrl,"//","/")
DefiniteUrl=Replace(DefiniteUrl,":\\","://")
Else
DefiniteUrl="$$$"
End If
End Function
'#############################################################################
'生成缩略图及水印选项
Public Function IsObjInstalled(strClassString)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj:Set xTestObj = Server.CReateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function
Public Function IsExpiRed(strClassString)
On Error Resume Next
IsExpiRed = True
Err = 0
Dim xTestObj:Set xTestObj = Server.CReateObject(strClassString)
If 0 = Err Then
Select Case strClassString
Case "Persits.Jpeg"
If xTestObj.ExpiRes > Now Then
IsExpiRed = False
End If
Case "wsImage.Resize"
If InStr(xTestObj.errorinfo, "已经过期") = 0 Then
IsExpiRed = False
End If
Case "SoftArtisans.ImageGen"
xTestObj.CReateImage 500, 500, RGB(255, 255, 255)
If Err = 0 Then
IsExpiRed = False
End If
End Select
End If
Set xTestObj = Nothing
Err = 0
End Function
'为图片添加水印
Function AddWaterMark(FileName)
Dim SK
Dim objFileSystem, strFileExtName, objImage
If InStr(FileName, ":") = 0 Then
FileName = Server.MapPath(FileName)
End If
If FileName <> "" And Not IsNull(FileName) Then
strFileExtName = ""
If InStr(FileName, ".") <> 0 Then
strFileExtName = LCase(Trim(Mid(FileName, InStrRev(FileName, ".") + 1)))
End If
If strFileExtName <> "jpg" And strFileExtName <> "gif" And strFileExtName <> "bmp" And strFileExtName <> "png" Then
Exit Function
End If
Set objFileSystem = Server.CreateObject(WR_Setting(14))
If objFileSystem.FileExists(FileName) Then
If WR_UpLoad(25) <> "0" Then
Select Case WR_UpLoad(25)
Case "1"
If IsObjInstalled("Persits.Jpeg") Then
If IsExpired("Persits.Jpeg") Then
Response.Write ("对不起，Persits.Jpeg组件已过期<br><a href=# Onclick=""javascript:history.back()"">返回</a>")
Response.End
End If
If WR_UpLoad(27) = "1" Then
AddWordMark 1, WR_UpLoad(28), WR_UpLoad(30), WR_UpLoad(31), WR_UpLoad(32), WR_UpLoad(29), WR_UpLoad(26), FileName
Else
AddPhotoMark 1, WR_UpLoad(36), WR_UpLoad(37), WR_UpLoad(33), WR_UpLoad(34), WR_UpLoad(35), WR_UpLoad(26), FileName
End If
End If
End Select
End If
End If
Set objFileSystem = Nothing
End If
End Function
'为图片添加文字水印函数
Function AddWordMark(MarkComponentID, MarkText, MarkFontColor, MarkFontName, MarkFontBond, MarkFontSize, MarkPosition, FileName)
Dim objImage, x, y, Text, TextWidth, FontColor, FontName, FondBond, FontSize, OriginalWidth, OriginalHeight
If InStr(FileName, ":") = 0 Then
FileName = Server.MapPath(FileName)
End If
Text = Trim(MarkText)
If Text = "" Then
Exit Function
End If
FontColor = Replace(MarkFontColor, "#", "&H")
FontName = MarkFontName
If MarkFontBond = "1" Then
FondBond = True
Else
FondBond = False
End If
FontSize = CInt(MarkFontSize)
Select Case MarkComponentID
Case 1
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -