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
