-
'================================================
-
'函数名：FormatRemoteUrl
-
'作 用：格式化成当前网站完整的URL-将相对地址转换为绝对地址
-
'参 数： url ----Url字符串
-
'参 数： CurrentUrl ----当然网站URL
-
'返回值：格式化取后的Url
-
'================================================
-
Public Function FormatRemoteUrl(ByVal URL,ByVal CurrentUrl)
-
Dim strUrl
-
If Len(URL) < 2 Or Len(URL) > 255 Or Len(CurrentUrl) < 2 Then
-
FormatRemoteUrl = vbNullString
-
Exit Function
-
End If
-
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))
-
If InStr(9, CurrentUrl, "/") = 0 Then
-
strUrl = CurrentUrl
-
Else
-
strUrl = Left(CurrentUrl, InStr(9, CurrentUrl, "/") - 1)
-
End If
-
-
If strUrl = vbNullString Then strUrl = CurrentUrl
-
Select Case Left(LCase(URL), 6)
-
Case "http:/", "https:", "ftp://", "rtsp:/", "mms://"
-
FormatRemoteUrl = URL
-
Exit Function
-
End Select
-
-
If Left(URL, 1) = "/" Then
-
FormatRemoteUrl = strUrl & URL
-
Exit Function
-
End If
-
-
If Left(URL, 3) = "../" Then
-
Dim ArrayUrl
-
Dim ArrayCurrentUrl
-
Dim ArrayTemp()
-
Dim strTemp
-
Dim i, n
-
Dim c, l
-
n = 0
-
ArrayCurrentUrl = Split(CurrentUrl, "/")
-
ArrayUrl = Split(URL, "../")
-
c = UBound(ArrayCurrentUrl)
-
l = UBound(ArrayUrl) + 1
-
-
If c > l + 2 Then
-
For i = 0 To c - l
-
ReDim Preserve ArrayTemp(n)
-
ArrayTemp(n) = ArrayCurrentUrl(i)
-
n = n + 1
-
Next
-
strTemp = Join(ArrayTemp, "/")
-
Else
-
strTemp = strUrl
-
End If
-
URL = Replace(URL, "../", vbNullString)
-
FormatRemoteUrl = strTemp & "/" & URL
-
Exit Function
-
End If
-
strUrl = Left(CurrentUrl, InStrRev(CurrentUrl, "/"))
-
FormatRemoteUrl = strUrl & Replace(URL, "./", vbNullString)
-
Exit Function
-
End Function
