Detect hyperlinks (URL) in a RichTextBox

[manavo11]

Private Const WM_USER As Long = &H400
Private Const EM_AUTOURLDETECT As Long = (WM_USER + 91)
Private Const EM_GETSEL As Long = &HB0
 
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
     ByVal hwnd As Long, _
     ByVal wMsg As Long, _
     ByVal wParam As Long, _
     lParam As Any) As Long
 
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
 
 
Option Explicit
 
Private Sub DetectURL(p_RichText As Object, p_blnDetect As Boolean)
    Dim lngRet As Long
    Dim strText As String
    
    With p_RichText
        ' this line is needed because the function will not update the
        ' url if you had it before
        strText = .Text
        ' send message to detect urls
        ' notice the Abs function. This is needed to pass 0 or 1
        ' in VB true is -1, so we have to get the absolute value of that
        lngRet = SendMessage(RichTextBox1.hwnd, EM_AUTOURLDETECT, Abs(p_blnDetect), ByVal 0)
        ' rewrite the text into the RichText so it will change all URLs if you
        'had them before
        .Text = strText
    End With
End Sub
 
Private Sub Form_Load()
 
    RichTextBox1.Text = "The URL to click is [url]http://www.something.com.[/url]  Please click it." & vbCrLf
    
End Sub
 
Private Sub RichTextBox1_Change()
    DetectURL RichTextBox1, True
    RichTextBox1.SelStart = Len(RichTextBox1.Text)
End Sub
 
 
Private Sub RichTextBox1_Click()
 
    Dim lngRetVal As Long
    
    lngRetVal = SendMessage(RichTextBox1.hwnd, EM_GETSEL, 0, 0)
    
    Dim strBuffer As String, intInStr As Integer, intHi As Integer, intLo As Integer
    
    intHi = HiWord(lngRetVal) + 1
    intLo = LoWord(lngRetVal) + 1
    
    intInStr = InStrRev(RichTextBox1.Text, " ", intLo)
    
    If intInStr = 0 Then 'no space
        strBuffer = Mid(RichTextBox1.Text, 1, intLo)
    Else
        strBuffer = Mid(RichTextBox1.Text, intInStr + 1)
    End If
    
    strBuffer = Trim(strBuffer)
    intInStr = InStr(1, strBuffer, " ")
    
    If intInStr <> 0 Then
        strBuffer = Mid(strBuffer, 1, intInStr - 1)
    End If
    
    If InStr(1, strBuffer, "http:") = 0 And _
        InStr(1, strBuffer, "file:") = 0 And _
        InStr(1, strBuffer, "mailto:") = 0 And _
        InStr(1, strBuffer, "ftp:") = 0 And _
        InStr(1, strBuffer, "https:") = 0 And _
        InStr(1, strBuffer, "gopher:") = 0 And _
        InStr(1, strBuffer, "nntp:") = 0 And _
        InStr(1, strBuffer, "prospero:") = 0 And _
        InStr(1, strBuffer, "telnet:") = 0 And _
        InStr(1, strBuffer, "news:") = 0 And _
        InStr(1, strBuffer, "wais:") = 0 Then Exit Sub
        
    Debug.Print strBuffer
    
    'to run
    'Call ShellExecute(Me.hwnd, "OPEN", strBuffer, vbNullString, vbNullString, 5)
    
End Sub
 
Private Function LoWord(ByVal DWord As Long) As Long
  If DWord And &H8000& Then
    LoWord = DWord Or &HFFFF0000
  Else
    LoWord = DWord And &HFFFF&
  End If
End Function
 
Private Function HiWord(ByVal DWord As Long) As Long
  HiWord = (DWord And &HFFFF0000) \ &H10000
End Function