'================================================
'函数名：FormatRemoteUrl
'作用：格式化成当前网站完整的URL-将相对地址转换为绝对地址
'参数：url----Url字符串
'参数：CurrentUrl----当然网站URL
'返回值：格式化取后的Url
'================================================
PublicFunctionFormatRemoteUrl(ByValURL,ByValCurrentUrl)
DimstrUrl
IfLen(URL)<2OrLen(URL)>255OrLen(CurrentUrl)<2Then
FormatRemoteUrl=vbNullString
ExitFunction
EndIf
CurrentUrl=Trim(Replace(Replace(Replace(Replace(Replace(CurrentUrl,"'",vbNullString),"""",vbNullString),vbNewLine,vbNullString),"","/"),"|",vbNullString))
URL=Trim(Replace(Replace(Replace(Replace(Replace(URL,"'",vbNullString),"""",vbNullString),vbNewLine,vbNullString),"","/"),"|",vbNullString))
IfInStr(9,CurrentUrl,"/")=0Then
strUrl=CurrentUrl
Else
strUrl=Left(CurrentUrl,InStr(9,CurrentUrl,"/")-1)
EndIf
IfstrUrl=vbNullStringThenstrUrl=CurrentUrl
SelectCaseLeft(LCase(URL),6)
Case"http:/","https:","ftp://","rtsp:/","mms://"
FormatRemoteUrl=URL
ExitFunction
EndSelect
IfLeft(URL,1)="/"Then
FormatRemoteUrl=strUrl&URL
ExitFunction
EndIf
IfLeft(URL,3)="../"Then
DimArrayUrl
DimArrayCurrentUrl
DimArrayTemp()
DimstrTemp
Dimi,n
Dimc,l
n=0
ArrayCurrentUrl=Split(CurrentUrl,"/")
ArrayUrl=Split(URL,"../")
c=UBound(ArrayCurrentUrl)
l=UBound(ArrayUrl)+1
Ifc>l+2Then
Fori=0Toc-l
ReDimPreserveArrayTemp(n)
ArrayTemp(n)=ArrayCurrentUrl(i)
n=n+1
Next
strTemp=Join(ArrayTemp,"/")
Else
strTemp=strUrl
EndIf
URL=Replace(URL,"../",vbNullString)
FormatRemoteUrl=strTemp&"/"&URL
ExitFunction
EndIf
strUrl=Left(CurrentUrl,InStrRev(CurrentUrl,"/"))
FormatRemoteUrl=strUrl&Replace(URL,"./",vbNullString)
ExitFunction
EndFunction
【FormatRemoteUrl函数之asp实现格式化成当前网站完整的URL-将相对地址转换为绝对地址的代码】相关文章：