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"

' 判断URLs和emails.

objRegExp.IgnoreCase = True

' 设置大小写不敏感..

objRegExp.Global = True

' 全局适用.

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=""URL:" & url & """超级链接:""" & _

Target & """>" & url & "</a>"

Else

strBuf = "<a href=""" & url & """超级链接:""" & _

Target & """>" & url & "</a>"

End If

ElseIf UCase(urlType) = "EMAIL" Then

strBuf = "<a href=""电子邮件地址:" & url & """链接目标:""" & _

Target & """>" & url & "</a>"

End If

GetHref = strBuf

End Function

[1]