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]
您可能感兴趣的文章:- 易语言将指定的主机名与IP地址转换功能
- PHP实现将优酷土豆腾讯视频html地址转换成flash swf地址的方法
- 将IP地址转换为整型数字的PHP方法、Asp方法和MsSQL方法、MySQL方法
- 两端口路由器地址转换的例子
- Cisco 路由器动态和静态地址转换
- FormatRemoteUrl函数之asp实现格式化成当前网站完整的URL-将相对地址转换为绝对地址的代码
- 使用网络地址转换实现多服务器负载均衡
- NAT网络地址转换详情
