[COLOR=blue]
Option Explicit
Public Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long '
Public Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)
Public 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
Public Const GWL_WNDPROC = (-4)
Public Const WM_USER = &H400
Public Const WM_NOTIFY = &H4E
Public Const WM_LBUTTONDOWN = &H201
Public Const EM_GETEVENTMASK = WM_USER + 59
Public Const EM_SETEVENTMASK = WM_USER + 69
Public Const EM_AUTOURLDETECT = WM_USER + 91
Public Const EM_GETTEXTRANGE = WM_USER + 75
Public Const EN_LINK = &H70B
Public Const ENM_LINK = &H4000000
Public Const SW_SHOWNORMAL = 1
Type tagNMHDR
hwndFrom As Long
idFrom As Long
code As Long
End Type
Type CHARRANGE
cpMin As Long
cpMax As Long
End Type
Type ENLINK
nmhdr As tagNMHDR
msg As Long
wParam As Long
lParam As Long
chrg As CHARRANGE
End Type
Type TEXTRANGE
chrg As CHARRANGE
lpstrText As Long
End Type
Public lpOriginalWndProc As Long
Public lOriginalhWnd As Long
Public myRTB As RichTextBox
Function RichTextBoxSubProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim udtNMHDR As tagNMHDR
Dim udtENLINK As ENLINK
Dim udtTEXTRANGE As TEXTRANGE
Dim strBuffer As String * 128
Dim strOperation As String
Dim strFileName As String
Dim strDefaultDirectory As String
Dim lhInstance As Long
Dim lResult As Long
' Do we have a notification?
If uMsg = WM_NOTIFY Then
RtlMoveMemory udtNMHDR, ByVal lParam, Len(udtNMHDR) ' Ok, get copy of notification message header
' Are we dealing with a click on a URL in our RTB
' If so, then do our own handling since Microsoft's implimentation
' simply ignores the notification
If udtNMHDR.hwndFrom = myRTB.hwnd And udtNMHDR.code = EN_LINK Then
RtlMoveMemory udtENLINK, ByVal lParam, Len(udtENLINK)
If udtENLINK.msg = WM_LBUTTONDOWN Then
strBuffer = ""
With udtTEXTRANGE
.chrg.cpMin = udtENLINK.chrg.cpMin
.chrg.cpMax = udtENLINK.chrg.cpMax
.lpstrText = StrPtr(strBuffer)
End With
With myRTB
lResult = SendMessage(.hwnd, EM_GETTEXTRANGE, 0, udtTEXTRANGE)
End With
RtlMoveMemory ByVal strBuffer, ByVal udtTEXTRANGE.lpstrText, Len(strBuffer)
strOperation = "open"
strFileName = strBuffer
lhInstance = ShellExecute(Form1.hwnd, strOperation, strFileName, vbNullString, strDefaultDirectory, SW_SHOWNORMAL)
End If
End If
End If
RichTextBoxSubProc = CallWindowProc(lpOriginalWndProc, hwnd, uMsg, wParam, lParam)
End Function
[/color]
Red-eyed, mumbling mammal capable of conversing with inanimate objects.