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
' 設(shè)置大小寫不敏感..
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地址轉(zhuǎn)換功能
- PHP實現(xiàn)將優(yōu)酷土豆騰訊視頻html地址轉(zhuǎn)換成flash swf地址的方法
- 將IP地址轉(zhuǎn)換為整型數(shù)字的PHP方法、Asp方法和MsSQL方法、MySQL方法
- 兩端口路由器地址轉(zhuǎn)換的例子
- Cisco 路由器動態(tài)和靜態(tài)地址轉(zhuǎn)換
- FormatRemoteUrl函數(shù)之a(chǎn)sp實現(xiàn)格式化成當前網(wǎng)站完整的URL-將相對地址轉(zhuǎn)換為絕對地址的代碼
- 使用網(wǎng)絡(luò)地址轉(zhuǎn)換實現(xiàn)多服務(wù)器負載均衡
- NAT網(wǎng)絡(luò)地址轉(zhuǎn)換詳情
