'replaces relative href And src links To a Base absolute URL In HTML code
' 2005 Antonin Foller, Motobit Software
function ReplaceLinksToBase(ByVal HTML, BaseURL)
' replace <a href=...> links
HTML = ReplaceTagToBase(HTML, "a", "href", BaseURL)
' replace <img src=...> links
HTML = ReplaceTagToBase(HTML, "img", "src", BaseURL)
HTML = ReplaceTagToBase(HTML, "link", "href", BaseURL)
ReplaceLinksToBase = HTML
End Function
'replaces relative links In one tag To a BaseURL.
function ReplaceTagToBase(ByVal HTML, ByVal TagName, byref ValueName, ByRef BaseURL)
Dim Pos1, Pos2, P1, P2
'Find the tag In HTML.
Pos1 = InStr(1, HTML, "<" & TagName, 1)
Do While Pos1>0
'The tag was found. Find closing > of the tag.
Pos2 = InStr(Pos1+len(TagName)+1, HTML, ">", 0)
If Pos2>0 Then
'separate tag text from HTML
Dim Tag, Tag1
Tag = Mid(HTML, Pos1+1, Pos2-Pos1-1)
'rewrite realative URL links In the one tag.
'response.write "<br><br><b>" & Tag & "</b>"
Tag1 = ReplaceParamToBase(Tag, ValueName, baseURL)
'The tag was changed - relative links found.
If Tag1<>Tag Then 'there is some change In the tag.
'get parts before And after the tag
P1 = Left(HTML, Pos1)
P2 = Mid(HTML, Pos2)
'Compute new POs2 position
'response.write "<br>" & Tag1
'response.write "<br>" & Pos2
Pos2 = Pos2 + Len(Tag1) - Len(Tag)
'response.write "<br>" & Pos2
'replace old tag with relative links with the new version
HTML = P1 & Tag1 & P2
'response.write "<br>" & server.htmlencode(Mid(html, pos2+1, 50))
End If
End If
If Pos2>0 Then
'find Next tag.
Pos1 = InStr(Pos2+1, HTML, "<" & TagName, 1)
Else
Pos1 = 0
End If
Loop
ReplaceTagToBase = HTML
End Function
Function ReplaceParamToBase(ByVal Tag, byref ValueName, ByRef BaseURL)
Dim Pos1, Pos2, C1, LenVal, P1, P2
LenVal = Len(ValueName)+1
'find position of the tag value
Pos1 = InStr(1, Tag, ValueName & "=", 1)
'response.write "<br>" & Pos1
If Pos1>0 Then
'get a first char after =
C1 = Mid(Tag, Pos1+LenVal, 1)
If C1="""" Then
'the value is enclosed with quote
Pos1 = Pos1+LenVal+1
Pos2 = InStr(Pos1, Tag, """", 0)
elseif C1="'" Then
'the value is enclosed with apostrof
Pos1 = Pos1+LenVal+1
Pos2 = InStr(Pos1, Tag, "'", 0)
Else
'the value ends with Space
Pos1 = Pos1+LenVal
Pos2 = InStr(Pos1, Tag, " ", 0)
If pos2=0 Then Pos2 = Len(tag)+1
End If
P1 = Left(Tag, Pos1-1)
P2 = Mid(Tag, Pos2)
Url = Mid(Tag, Pos1, Pos2-Pos1)
'response.write "<br>" & url
'is the value relative URL?
If InStr(Url, "://") = 0 And InStr(1, Url, "mailto:", 1)=0 Then
'make the new absolute URL
URL = BaseURL & URL
'replace the Tag with the new absolute URL
Tag = P1 & URL & P2
'response.write "<br><font color=red>" & url & "</font>"
'response.write "<br><font color=red>" & tag & "</font>"
End If
End If
ReplaceParamToBase = Tag
End Function
|