RichTextBox Hyperlinks

				
'**************************************
' Name: RichTextBox Hyperlinks
' Description:Hyperlinks created using system calls have a few advantages such as detecting the link as you type, but if all you need is to identify links and respond to them, it can be done simply with VB commands only.
Update: It turns out the original code worked only because there was one link in the sample. The SelStart property only works on the Text portion of the RichTextBox. It does not work correctly with the TextRTF portion. Web links are not supposed to contain any spaces, so I searched for the preceding space character. Then I searched for the ending Chr$(127) which I added to each link because it is a non-printable character. Now it works with multiple links.
' By: J.A. Coutts
'
'This code is copyrighted and has' limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=74547&lngWId=1'for details.'**************************************

-Start a new project and add the Microsoft Rich Textbox Control component
-Drop a RichTextBox control and a Command Button control onto the form
-Expand the RichTextBox to at least 80 characters wide and enable Verical Scrollbars
-Rename the controls appropriately, and add the code below
-Run the program and copy some text with "http://" links in it to the RichTextBox
-Click the cmdFind button and links will be made blue and underlined
-Double Click a link, and the page will be loaded in your default Web browser
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Sub FindLinks()
Dim M%, N%
Dim strTemp1 As String
With RTB1
N% = .Find("http")
Do Until N% < 0
M% = .Find(vbCrLf, N%)
If M% = 0 Then M% = Len(.Text)
.SelStart = N%
.SelLength = M% - N%
strTemp1 = " \cf1\ul " & Mid$(.Text, N% + 1, M% - N%) & Chr$(127) & "\cf0\ulnone "
Debug.Print strTemp1
.SelRTF = strTemp1
N% = .Find("http", M%)
Loop
.Text = Replace(.Text, vbCrLf, "\par ")
End With
End Sub
Sub AddFormat()
RTB1 = "{\rtf1\ansi\deff0{\fonttbl{\f0\fnil\fcharset0 Courrier New;}}" & Chr(13) _
& "{\colortbl ;\red0\green0\blue255;} " & Chr(13) _
& "\viewkind4\uc1\pard\lang1033\f0\fs19 " _
& RTB1.Text & Chr(13) & "\par }"
End Sub
Private Sub cmdFind_Click()
Call FindLinks
Call AddFormat
End Sub
Private Sub RTB1_DblClick()
Dim RetVal As Long
Dim lStart As Long
Dim lEnd As Long
Dim HyperLink As String
With RTB1
If .SelColor = vbBlue And .SelUnderline Then
'Step backwards to the beginning of the Hyperlink
.UpTo " ", False
lStart = .SelStart + 1
If lStart > 1 Then
'Step forward to the end of the hyperlink
.UpTo Chr$(127), True
lEnd = .SelStart + 1
If lEnd > lStart Then
HyperLink = Mid$(.Text, lStart, lEnd - lStart)
Else
MsgBox "Could not find end of link!", vbExclamation
Exit Sub
End If
Else
MsgBox "Could not find start of link!", vbExclamation
Exit Sub
End If
'Now launch the default browser to that page
RetVal = ShellExecute(0&, "open", HyperLink, 0, 0, 1)
End If
End With
End Sub