?? sk_funcls.asp
字號:
'===============================================
'函數名：GetArray
'作 用：提取鏈接地址，以$Array$分隔
'參 數：ConStr ------提取地址的原字符
'參 數：StartStr ------開始字符串
'參 數：OverStr ------結束字符串
'參 數：IncluL ------是否包含StartStr
'參 數：IncluR ------是否包含OverStr
'===============================================
Function GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
Dim TempStr,TempStr2,objRegExp,Matches,Match,Templisturl,TempStr_i
Dim s,o
On Error Resume Next
If ConStr="$False$" or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
GetArray="$False$"
Exit Function
End If
StartStr=ReplaceTrim(StartStr) : OverStr=ReplaceTrim(OverStr) : ConStr=ConStr
s=Len(StartStr) : o=Len(OverStr)
TempStr=""
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "("&CorrectPattern(StartStr)&").+?("&CorrectPattern(OverStr)&")"
Set Matches =objRegExp.Execute(ConStr)
For Each Match in Matches
'If Templisturl =Match.Value then
'Else
TempStr_i=Match.Value
If IncluL=False then
TempStr_i=Right(TempStr_i,Len(TempStr_i) -S)
End if
If IncluR=False then
TempStr_i=Left(TempStr_i,Len(TempStr_i) - O)
End if
TempStr=TempStr & "$Array$" & TempStr_i
' Templisturl = Match.Value
'End if
Next
Set Matches=nothing
If TempStr="" Then
GetArray="$False$"
Exit Function
End If
TempStr=Right(TempStr,Len(TempStr)-7)
Set objRegExp=nothing
Set Matches=nothing
If TempStr="" then
GetArray="$False$"
Else
GetArray=TempStr
End if
End Function
'===============================================
'函數名：ReplaceSaveRemoteFile
'作 用：替換、保存遠程圖片
'參 數：ConStr ------ 要替換的字符串
'參 數：SaveTf ------ 是否保存文件，False不保存，True保存
'參 數: TistUrl------ 當前網頁地址
'===============================================
Function ReplaceSaveRemoteFile(ConStr,strInstallDir,strChannelDir,SaveTf,TistUrl)
If ConStr="$False$" or ConStr="" or strChannelDir="" Then
ReplaceSaveRemoteFile=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 ="<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
IncludePic=1'圖片新聞
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= strChannelDir & year(DtNow) & right("0" & month(DtNow),2) & "/"
response.write "鏈接路徑：" & savepath & "<br>"
Arr_Path=Split(SavePath,"/")
PathTemp=""
For Tempi=0 To Ubound(Arr_Path)
If Tempi=0 Then
PathTemp=Arr_Path(0) & "/"
ElseIf Tempi=Ubound(Arr_Path) Then
Exit For
Else
PathTemp=PathTemp & Arr_Path(Tempi) & "/"
End If
If CheckDir(PathTemp)=False Then
If MakeNewsDir(PathTemp)=False Then
SaveTf=False
Exit For
End If
End If
Next
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$")
'去掉重復圖片結束
'轉換相對圖片地址開始
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)
If SaveRemoteFile(SavePath & strFileName,RemoteFileUrl)=True Then
PathTemp=SavePath & strFileName
ConStr=Re.Replace(ConStr,PathTemp)
Re.Pattern=strInstallDir & strChannelDir
UploadFiles=UploadFiles & "|" & Re.Replace(SavePath &strFileName,"")
Response.Flush()
response.write " 圖片保存地址：" & PathTemp & "<br>"
if Thumb_WaterMark=1 then call SKThumb.AddWaterMark(PathTemp)'水印
Else
PathTemp=RemoteFileUrl
ConStr=Re.Replace(ConStr,PathTemp)
'UploadFiles=UploadFiles & "|" & RemoteFileUrl
End If
ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存圖片
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
UploadFiles=UploadFiles & "|" & RemoteFileUrl
End If
Next
Set Re=nothing
If UploadFiles<>"" Then
UploadFiles=Right(UploadFiles,Len(UploadFiles)-1)
End If
ReplaceSaveRemoteFile=ConStr
End function
'===============================================
'函數名：ReSaveRemoteFile
'作 用：查找文件保存替換
'參 數：Str ----原字符串
'參 數：url ----當然網站URL
'參 數：Dir -----保存目錄
'參 數：InSave ------是否保存,True,False
'返回值：格式化取后的字符串
'===============================================
Public Function ReSaveRemoteFile(ByVal str, ByVal URL, ByVal Dir,InSave)
Dim s_Content
Dim re
Dim ContentFile, ContentFileUrl
Dim strTempUrl,strFileUrl,DirTemp,PathTemp,FileTemp,Tempi,TempUrlArray,Arr_Path
s_Content = str
On Error Resume Next
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "((src=|href=)((\S)+[.]{1}(" & AllExtName & ")))"
Set ContentFile = re.Execute(s_Content)
Dim sContentUrl(), n, i, bRepeat
n = 0
For Each ContentFileUrl In ContentFile
strFileUrl = Replace(Replace(Replace(Replace(ContentFileUrl.Value, "src=", "", 1, -1, 1), "href=", "", 1, -1, 1), "'", ""), Chr(34), "")
If n = 0 Then
n = n + 1
ReDim sContentUrl(n)
sContentUrl(n) = strFileUrl
Else
bRepeat = False
For i = 1 To UBound(sContentUrl)
If UCase(strFileUrl) = UCase(sContentUrl(i)) Then
bRepeat = True
Exit For
End If
Next
If bRepeat = False Then
n = n + 1
ReDim Preserve sContentUrl(n)
sContentUrl(n) = strFileUrl
End If
End If
Next
If n = 0 Then
ReSaveRemoteFile = s_Content
Exit Function
End If
For i = 1 To n
strTempUrl = sContentUrl(i) : strTempUrl = FormatRemoteUrl(strTempUrl,URL)'得到文件地址
IF InSave=True then
Arr_Path=Split(Dir,"/")
'----------建目錄-----------------------
For Tempi=0 To Ubound(Arr_Path)
If Tempi=0 Then
PathTemp=Arr_Path(0) & "/"
ElseIf Tempi=Ubound(Arr_Path) Then
Exit For
Else
PathTemp=PathTemp & Arr_Path(Tempi) & "/"
End If
If CheckDir(PathTemp)=False Then
If MakeNewsDir(PathTemp)=False Then
SaveTf=False
Exit For
End If
End If
Next
'------------------------------------------------------
TempUrlArray=Split(strTempUrl,"/")
'----------檢查文件是否存在.如果存在換文件名------------------
Do while True
FileTemp=Dir & MakeRandom(5) & TempUrlArray(Ubound(TempUrlArray))'生成隨機文件名
If CheckFile(FileTemp)=False then
Exit Do
end if
loop
'-------------------------------------------------------------------
If SaveRemoteFile(FileTemp,strTempUrl)=True then
Response.Write FileTemp & "保存成功" & "<Br>"
s_Content = Replace(s_Content,sContentUrl(i),FileTemp, 1, -1, 1)'替換地址
Else
Response.Write FileTemp & "保存失敗" & "<Br>"
End if
Else
s_Content = Replace(s_Content,sContentUrl(i),strTempUrl, 1, -1, 1)'替換地址
End If
Next
Set re = Nothing
PictureExist = True
ReSaveRemoteFile = s_Content
Exit Function
End Function
'===============================================
'過程名：SaveRemoteFile
'作 用：保存遠程的文件到本地
'參 數：LocalFileName ------ 本地文件名
'參 數：RemoteFileUrl ------ 遠程文件URL
'===============================================
Function SaveRemoteFile(LocalFileName,RemoteFileUrl)
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -