InsertHyperlinks + GetHref

Converts https found in text into anchers < a >
Comes with GetHref as bonus
Newer version of http://mydev.net/?DevID=8NQ0L7

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

Parameters

inText

Views 135 Downloads 54

Perm link


ANmarAmdeen
283
Texts + Strings Classic ASP
Revisions

v1.0

Tags