URL links in ReachTextBox

[jsbach]

Greetings.
I saved an RTF file (a word document) in a resource file and then I loaded it to a RichTextBox control.
The RTF file contains some URL links but they appear to be dead in the RichTextBox control.
Any ideas on how I can get those links revived?
Thanks.

[Jmacp]

I think you have to cut the cur coordinates of the text link in the richtextbox and hence when the cursor is within that area and dbl clicked execute the link.

[jsbach]

Perhaps few lines of code?

[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

[Shawn N]

Nice coding manavo.

[jsbach]

manavo, I appreciate your effort. However your code didn't work for me

Do you think you could do one more little effort and attach a small project to demonstrate your code?
Thanks allot!

[manavo11]

Originally posted by Shawn N
Nice coding manavo.

I can't take credit for it... I found it somewhere around here and saved it on my PC... It was easier to search my PC then VBF

Here's the project I have saved on my PC...