'================================================ '函数名：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
