Hyperlink in Textbox or Richtextbox?
robert madrian
Is it possible to extend a Textbox or Richtextbox to use Hyperlinks like
Word?
If I klick on such a link it sould open the default Browser.
regrads robert
MikeD
"robert madrian" <off...@madrian.at> wrote in message
news:Og2pA$zBEH...@TK2MSFTNGP10.phx.gbl...
> Hello,
>
> Is it possible to extend a Textbox or Richtextbox to use Hyperlinks like
> Word?
TextBox...No
RichTextBox...Yes (with some API and subclassing)
Start a new standard EXE project. Add a RichTextBox and name it RTB1. Add
a command button, name it cmdClose, and give it an appropriate caption. Add
a standard code module (.bas file) to the project. Copy the following code
(most certainly, some of the lines of code will have word-wrapped, so be
cautious of that) and paste it into the General Declarations section of the
.bas:
----BEGIN CODE
Option Explicit
'This module provides RichTextBox features that are not
'natively exposed by the RichTextBox control but the RichEdit
'supports. Currently, this is only for auto-detecting
'URLs (which formats a URL as a hyerplink) and clicking
'the URL to launch a default web browser, email program, etc.
Private lpfnOldWinProc As Long
Private m_lRTBhWnd As Long
Private Const WM_LBUTTONDBLCLK As Long = &H203
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_MBUTTONDBLCLK As Long = &H209
Private Const WM_MBUTTONDOWN As Long = &H207
Private Const WM_MBUTTONUP As Long = &H208
Private Const WM_RBUTTONDBLCLK As Long = &H206
Private Const WM_RBUTTONDOWN As Long = &H204
Private Const WM_RBUTTONUP As Long = &H205
Private Const WM_DESTROY As Long = &H2
Private Const WM_USER As Long = &H400
Private Const GWL_WNDPROC As Long = (-4)
Private Const EM_GETAUTOURLDETECT As Long = (WM_USER + 92)
Private Const EM_AUTOURLDETECT As Long = (WM_USER + 91)
Private Const EM_SETEVENTMASK As Long = (WM_USER + 69)
Private Const EM_GETEVENTMASK As Long = (WM_USER + 59)
Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOW As Long = 5
Private Const EN_LINK As Long = &H70B&
Private Const ENM_LINK As Long = &H4000000
Private Const WM_NOTIFY As Long = &H4E&
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
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA"
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias
"GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory"
(Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA"
(ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal uMsg As Long, ByVal
wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Type NMHDR
hwndFrom As Long
idfrom As Long
code As Long
End Type
Private Type CharRange
cpMin As Long
cpMax As Long
End Type
Private Type ENLINK
NMHDR As NMHDR
msg As Long
wParam As Long
lParam As Long
chrg As CharRange
End Type
Public Function DisableURLDetection(ByVal RTBhwnd As Long) As Boolean
Dim lEventMask As Long
'Need to get current event mask
lEventMask = SendMessage(RTBhwnd, EM_GETEVENTMASK, 0&, ByVal 0&)
'Remove the ENM_LINK mask
lEventMask = lEventMask And Not ENM_LINK
'Now set the new event mask
Call SendMessage(RTBhwnd, EM_SETEVENTMASK, 0&, ByVal lEventMask)
'Disable URL detection
Call SendMessage(RTBhwnd, EM_AUTOURLDETECT, 0&, ByVal 0&)
DisableURLDetection = True
End Function
Public Function EnableURLDetection(ByVal RTBhwnd As Long) As Boolean
Dim lEventMask As Long
Call SendMessage(RTBhwnd, EM_AUTOURLDETECT, 1&, ByVal 0&)
'Need to get current event mask
lEventMask = SendMessage(RTBhwnd, EM_GETEVENTMASK, 0&, ByVal 0&)
'Add the ENM_LINK mask
lEventMask = lEventMask Or ENM_LINK
'Now set the new event mask
Call SendMessage(RTBhwnd, EM_SETEVENTMASK, 0&, ByVal lEventMask)
'Cache the handle, as we'll need it later
m_lRTBhWnd = RTBhwnd
EnableURLDetection = True
End Function
Public Function EnableURLHook(ByVal hwnd As Long) As Boolean
'This function enables subclassing
'We must already have the RichTextBox's window handle.
'This is set by calling EnableURLDetection.
If m_lRTBhWnd = 0 Then
EnableURLHook = False
Else
'Get the address for the previous window procedure
lpfnOldWinProc = GetWindowLong(hwnd, GWL_WNDPROC)
If lpfnOldWinProc = 0 Then
'If the return value is 0, the function failed
EnableURLHook = False
Else
'The return value of SetWindowLong is the address of the
previous procedure,
'so if it's not what we just got above, something went wrong.
If SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WndProc) <>
lpfnOldWinProc Then
EnableURLHook = False
Else
EnableURLHook = True
End If
End If
End If
End Function
Public Function DisableURLHook(ByVal hwnd As Long) As Boolean
'Restore default window procedure
If SetWindowLong(hwnd, GWL_WNDPROC, lpfnOldWinProc) = 0 Then
DisableURLHook = False
Else
DisableURLHook = True
lpfnOldWinProc = 0
End If
End Function
Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal
wParam As Long, ByVal lParam As Long) As Long
Dim udtENLINK As ENLINK
Dim sURL As String
Dim lPos1 As Long
Dim lPos2 As Long
Dim sRTBText As String
Dim lRTBTextLength As Long
Select Case uMsg
Case WM_DESTROY
'In case it wasn't already done, un-subclass the window
Call CallWindowProc(lpfnOldWinProc, hwnd, uMsg, wParam, lParam)
Call DisableURLHook(hwnd)
Case WM_NOTIFY
'Now it gets a bit tricky. lParam is a pointer to an ENLINK
structure.
'The pointer is the memory address of where the structure
resides.
'We need to fill a local variable for that structure from the
pointer.
CopyMemory udtENLINK, ByVal lParam, Len(udtENLINK)
'Make sure the notification is from the RTB
If udtENLINK.NMHDR.hwndFrom <> m_lRTBhWnd Then
WndProc = CallWindowProc(lpfnOldWinProc, hwnd, uMsg, wParam,
lParam)
Exit Function
End If
'Make sure this is the EN_LINK notification
If udtENLINK.NMHDR.code <> EN_LINK Then
WndProc = CallWindowProc(lpfnOldWinProc, hwnd, uMsg, wParam,
lParam)
Exit Function
End If
'Now see if this is a left mouse up message
If udtENLINK.msg = WM_LBUTTONUP Then
'We get the first and last character position of the link
from
'the CHARRANGE structure.
lPos1 = udtENLINK.chrg.cpMin
lPos2 = udtENLINK.chrg.cpMax
'Because we don't have a direct reference to the RichTextBox
'control, we need to get its text via API functions
'This function gives us the length of the text (number of
characters)
lRTBTextLength = GetWindowTextLength(m_lRTBhWnd)
'Set up a buffer variable which will receive the text.
'Buffer variables used in API functions almost always must
'be pre-allocated to the size of the text that the buffer
'will receive; otherwise, the function usually causes the
'application to crash or only part of the text will be
'retrieved. Add 1 to accomodate a terminating null
'character.
sRTBText = String$(lRTBTextLength + 1, vbNullChar)
'Get the text from the RTB
Call GetWindowText(m_lRTBhWnd, sRTBText, lRTBTextLength + 1)
'Extract the URL
sURL = Trim$(Mid$(StripNulls(sRTBText), lPos1 + 1, lPos2 -
lPos1))
'Launch the URL using whatever the default application is
Call ShellExecute(0&, "open", sURL, vbNullString,
vbNullString, SW_SHOW)
'Return a non-zero since we processed the message
WndProc = 1
Else
WndProc = CallWindowProc(lpfnOldWinProc, hwnd, uMsg, wParam,
lParam)
End If
Case Else
WndProc = CallWindowProc(lpfnOldWinProc, hwnd, uMsg, wParam,
lParam)
End Select
End Function
Public Function StripNulls(ByVal sText As String) As String
'Returns all characters up to a null character.
'If the string does not contain a null character,
'the string is returned unmodified.
Dim lNullPos As Long
lNullPos = InStr(sText, vbNullChar)
If lNullPos Then
StripNulls = Left$(sText, lNullPos - 1)
Else
StripNulls = sText
End If
End Function
-----END CODE
Now copy and paste the following code into the General Declarations section
of Form1:
-----BEGIN CODE
Option Explicit
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub Form_Load()
EnableURLDetection RTB1.hwnd
'It's the RTB's parent that we need to subclass
'because it's the parent that actually receives the
'notification.
EnableURLHook Me.hwnd
End Sub
Private Sub Form_Resize()
On Error Resume Next
With cmdClose
.Move ScaleWidth - .Width - 200, ScaleHeight - .Height - 50
RTB1.Move 90, 90, ScaleWidth - 180, .Top - 200
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
DisableURLDetection RTB1.hwnd
DisableURLHook Me.hwnd
End Sub
-----END CODE
Save the project and run it. Type any URL into the RichTextBox. It should
automatically get formatted according to the system's settings for
hyperlinks. Moving the mouse pointer over it should change the pointer to
the hand icon. Clicking on it should launch the appropriate default
application.
I suggest consulting the Platform SDK for more information. Specifically,
look up the EM_* messages used above, etc.
I have only tested this with VB6 and Rich TextBox Control 6.0 (SP4) and
under Windows 2000. The Platform SDK states that RichEdit 2.0 is required.
This does not refer to the RTB control, but rather the version of RichEdit
installed on the system. It should work on any system that has RichEdit 2.0
or later.
Mike
robert madrian
If I start the project at the following line the vb6 ide chrashes without an
error (closes vb)
EnableURLHook Me.hwnd
regards
"MikeD" <nob...@nowhere.edu> schrieb im Newsbeitrag
news:%23JqTy$3BEHA...@tk2msftngp13.phx.gbl...
MikeD
> Hallo,
>
> If I start the project at the following line the vb6 ide chrashes without
an
> error (closes vb)
>
> EnableURLHook Me.hwnd
>
Hmmm....not sure what to tell you. I've given pretty much that exact same
code to a number of other people and they have not had problems with it, nor
have I had any problems with it. The problem you're having is obviously
related to subclassing the form. Verify the WndProc function in your demo
project to what I posted, particularly the function header.
Some other things....
Are you sure you copied the specified code into a BAS module? What happens
if you step into the EnableURLHook function and execute the code in that
function line by line (IOW, press F8)? Did you change ANYTHING in the code
I posted? Did you correct (properly) any lines of code from the posted
message that may have word-wrapped? What service pack, if any, for VB6 do
you have installed? What is the OS?
I can't really see how or why this would make a difference, but change the
above line of code to this:
If Not EnableURLHook(Me.hwnd) Then
MsgBox "Unable to create subclass"
End If
After you've gone over the code and made sure everything is "correct", if
you still have the problem, you might want to try it instead using a
subclassing control. There are a number of free ones available. One is
MsgHook, although I'm not sure where you can get this nowadays.
And just so that I can better assist you (if you still need it), are you
familiar with subclassing?
Mike
robert madrian
now causes the error
Thanks for your help
PS: I'm not familiar with subclassing
"MikeD" <nob...@nowhere.edu> schrieb im Newsbeitrag
news:OMgMp0D...@tk2msftngp13.phx.gbl...
MikeD
> I will take another look to my code - maybe i have changed some code which
> now causes the error
> Thanks for your help
>
> PS: I'm not familiar with subclassing
I'd DEFINTELY recommend using a subclassing control then.
Mike