InsertHyperlinks+GetHref

Changes all URLs or email addresses in a text into hyperlinks

CodeFunctionName
What is this?

Public

Tested

Original Work
'----------------------------------------------
' InsertHyperlinks(inText)
' Returns a inText with " <a href="URL" target="_BLANK" >URL </a >"
' inserted where there is URL found.
'
' URL can start with "www" or "http"
' or
' URL can be a email address "*@*"
'----------------------------------------------
<%
Function InsertHyperlinks(inText)
Dim objRegExp, strBuf
Dim objMatches, objMatch
Dim Value, ReplaceValue, iStart, iEnd

strBuf = ""
iStart = 1
iEnd = 1
Set objRegExp = New RegExp

objRegExp.Pattern = "\b(www|http|\S+@)\S+\b" ' Match URLs and emails
objRegExp.IgnoreCase = True ' Set case insensitivity.
objRegExp.Global = True ' Set global applicability.
Set objMatches = objRegExp.Execute(inText)
For Each objMatch in objMatches
iEnd = objMatch.FirstIndex
strBuf = strBuf & Mid(inText, iStart, iEnd-iStart+1)
If InStr(1, objMatch.Value, "@") Then
strBuf = strBuf & GetHref(objMatch.Value, "EMAIL", "_BLANK")
Else
strBuf = strBuf & GetHref(objMatch.Value, "WEB", "_BLANK")
End If
iStart = iEnd+objMatch.Length+1
Next
strBuf = strBuf & Mid(inText, iStart)
InsertHyperlinks = strBuf
End Function

Function GetHref(url, urlType, Target)
Dim strBuf
strBuf = " <a href="""
If UCase(urlType) = "WEB" Then
If LCase(Left(url, 3)) = "www" Then
strBuf = " <a href=""http://" & url & """ Target=""" & _
Target & """ >" & url & " </a >"
Else
strBuf = " <a href=""" & url & """ Target=""" & _
Target & """ >" & url & " </a >"
End If
ElseIf UCase(urlType) = "EMAIL" Then
strBuf = " <a href=""mailto:" & url & """ Target=""" & _
Target & """ >" & url & " </a >"
End If

GetHref = strBuf

End Function
% >

Views 5,145

Downloads 1,610

CodeID
DB ID

JeffSmith
26
Revisions

v1.0

Monday
April
23
2018