Ver Mensaje Individual
  #3 (permalink)  
Antiguo 08/06/2007, 08:54
yomesmo
 
Fecha de Ingreso: noviembre-2003
Ubicación: Madrid
Mensajes: 353
Antigüedad: 21 años, 5 meses
Puntos: 1
Re: Función que sustituya Http por enlace directo

La pongo por si le sirve a alguien en el futuro:

<%
'----------------------------------------------
' URL pueden empezar con "www" o "http"
' o
' URL pueden ser emails "*@*"
'----------------------------------------------
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
%>
__________________
Lo menos frecuente en este mundo es vivir. La mayoría de la gente existe, eso es todo...