DimobjRegExp,strBuf

DimobjMatches,objMatch

DimValue,ReplaceValue,iStart,iEnd

strBuf=""

iStart=1

iEnd=1

SetobjRegExp=NewRegExp

objRegExp.Pattern="\b(www|http|\S+@)\S+\b"

'判断URLs和emails.

objRegExp.IgnoreCase=True

'设置大小写不敏感..

objRegExp.Global=True

'全局适用.

SetobjMatches=objRegExp.Execute(inText)

ForEachobjMatchinobjMatches

iEnd=objMatch.FirstIndex

strBuf=strBuf&Mid(inText,iStart,iEnd-iStart+1)

IfInStr(1,objMatch.Value,"@")Then

strBuf=strBuf&GetHref(objMatch.Value,"EMAIL","_BLANK")

Else

strBuf=strBuf&GetHref(objMatch.Value,"WEB","_BLANK")

EndIf

iStart=iEnd+objMatch.Length+1

Next

strBuf=strBuf&Mid(inText,iStart)

InsertHyperlinks=strBuf

EndFunction

FunctionGetHref(url,urlType,Target)

DimstrBuf

strBuf="<ahref="""

IfUCase(urlType)="WEB"Then

IfLCase(Left(url,3))="www"Then

strBuf="<ahref=""URL:"&url&"""超级链接:"""&_

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

Else

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

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

EndIf

ElseIfUCase(urlType)="EMAIL"Then

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

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

EndIf

GetHref=strBuf

EndFunction