I have subclassed a RichTextBox to open URLs. Well, it does open up a browser (and with the code below it opens in a new browser window), but atleast Mozilla Firebird doesn't open the given url, only itself and the default homepage. Does the code below work for anyone?
VB Code:
Private Const CREATE_NEW_CONSOLE As Long = &H10 Private Const NORMAL_PRIORITY_CLASS As Long = &H20 Private Const INFINITE As Long = -1 Private Const STARTF_USESHOWWINDOW As Long = &H1 Private Const SW_SHOWNORMAL As Long = 1 Private Const MAX_PATH As Long = 260 Private Const ERROR_FILE_NO_ASSOCIATION As Long = 31 Private Const ERROR_FILE_NOT_FOUND As Long = 2 Private Const ERROR_PATH_NOT_FOUND As Long = 3 Private Const ERROR_FILE_SUCCESS As Long = 32 'my constant Private Const ERROR_BAD_FORMAT As Long = 11 Private Type STARTUPINFO cb As Long lpReserved As String lpDesktop As String lpTitle As String dwX As Long dwY As Long dwXSize As Long dwYSize As Long dwXCountChars As Long dwYCountChars As Long dwFillAttribute As Long dwFlags As Long wShowWindow As Integer cbReserved2 As Integer lpReserved2 As Long hStdInput As Long hStdOutput As Long hStdError As Long End Type Private Type PROCESS_INFORMATION hProcess As Long hThread As Long dwProcessId As Long dwThreadID As Long End Type Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpAppName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function FindExecutable Lib "shell32" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal sResult As String) As Long Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nSize As Long, ByVal lpBuffer As String) As Long Private Function StartNewBrowser(sURL As String) As Boolean Dim success As Long Dim hProcess As Long Dim sBrowser As String Dim start As STARTUPINFO Dim proc As PROCESS_INFORMATION sBrowser = GetBrowserName(success) If success >= ERROR_FILE_SUCCESS Then With start .cb = Len(start) .dwFlags = STARTF_USESHOWWINDOW .wShowWindow = SW_SHOWNORMAL End With success = CreateProcess(sBrowser, " " & sURL, 0&, 0&, 0&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc) StartNewBrowser = proc.hProcess <> 0 Call CloseHandle(proc.hProcess) Call CloseHandle(proc.hThread) End If End Function Private Function GetBrowserName(dwFlagReturned As Long) As String Dim hFile As Long Dim sResult As String Dim sTempFolder As String sTempFolder = GetTempDir() hFile = FreeFile Open sTempFolder & "dummy.html" For Output As #hFile Close #hFile sResult = Space$(MAX_PATH) dwFlagReturned = FindExecutable("dummy.html", sTempFolder, sResult) Kill sTempFolder & "dummy.html" GetBrowserName = TrimNull(sResult) End Function Private Function TrimNull(Item As String) Dim pos As Integer pos = InStr(Item, Chr$(0)) If pos Then TrimNull = Left$(Item, pos - 1) Else: TrimNull = Item End If End Function Public Function GetTempDir() As String Dim tmp As String tmp = Space$(256) Call GetTempPath(Len(tmp), tmp) GetTempDir = TrimNull(tmp) End Function
Code I use for RTB subclassing:
VB Code:
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 Type NMHDR hwndFrom As Long idfrom As Long code As Long End Type Private Type NMHDR_RICHEDIT hwndFrom As Long wPad1 As Integer idfrom As Integer code As Integer wPad2 As Integer End Type Private Type CHARRANGE cpMin As Long cpMax As Long End Type Private Type TEXTRANGE chrg As CHARRANGE lpstrText As Long End Type Private Type ENLINK NMHDR As NMHDR_RICHEDIT msg As Integer wPad1 As Integer wParam As Integer wPad2 As Integer lParam As Integer chrg As CHARRANGE End Type Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Const GWL_WNDPROC = (-4) Private Const WM_USER = &H400 Private Const WM_NOTIFY = &H4E Private Const WM_LBUTTONDBLCLK = &H203 Private Const WM_LBUTTONDOWN = &H201 Private Const WM_LBUTTONUP = &H202 Private Const WM_RBUTTONDBLCLK = &H206 Private Const WM_RBUTTONDOWN = &H204 Private Const WM_RBUTTONUP = &H205 Private Const WM_MBUTTONDBLCLK = &H209 Private Const WM_MBUTTONDOWN = &H207 Private Const WM_MBUTTONUP = &H208 Private Const EM_SETEVENTMASK = (WM_USER + 69) Private Const EM_GETTEXTRANGE = (WM_USER + 75) Private Const EM_AUTOURLDETECT = (WM_USER + 91) Private Const EM_EXSETSEL = (WM_USER + 55) Private Const ENM_LINK = &H4000000 Private Const ENM_NONE = &H0 Private Const EN_LINK = &H70B& Private mlWndProc As Long Public Sub EnableURLs(ByVal hWndParent As Long, ByVal hWndRTB As Long) Call SendMessage(hWndRTB, EM_AUTOURLDETECT, 1, ByVal 0) Call SendMessage(hWndRTB, EM_SETEVENTMASK, 0&, ByVal ENM_LINK) mlWndProc = SetWindowLong(hWndParent, GWL_WNDPROC, AddressOf SubClassedWindowProc) End Sub Public Sub DisableURLs(ByVal hWndParent As Long, ByVal hWndRTB As Long) Call SetWindowLong(hWndParent, GWL_WNDPROC, mlWndProc) Call SendMessage(hWndRTB, EM_AUTOURLDETECT, 0&, ByVal 0&) Call SendMessage(hWndRTB, EM_SETEVENTMASK, 0&, ByVal ENM_NONE) End Sub Private Function SubClassedWindowProc(ByVal hWnd As Long, ByVal nMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim tNMHDR As NMHDR Dim tENLINK As ENLINK Dim tTEXT As TEXTRANGE Dim sBuffer As String If nMsg = WM_NOTIFY Then Call CopyMemory(tNMHDR, ByVal lParam, Len(tNMHDR)) If tNMHDR.code = EN_LINK Then Call CopyMemory(tENLINK, ByVal lParam, Len(tENLINK)) If tENLINK.msg = WM_RBUTTONUP Then LSet tTEXT.chrg = tENLINK.chrg sBuffer = String(tTEXT.chrg.cpMax - tTEXT.chrg.cpMin, Chr(0)) tTEXT.lpstrText = StrPtr(sBuffer) Call SendMessage(tNMHDR.hwndFrom, EM_GETTEXTRANGE, 0, tTEXT) sBuffer = Replace(StrConv(sBuffer, vbUnicode), Chr(0), "") 'ShellExecute hWnd, "OPEN", sBuffer, "", "", 1 StartNewBrowser sBuffer End If End If End If SubClassedWindowProc = CallWindowProc(mlWndProc, hWnd, nMsg, wParam, lParam) End Function
Any help appreciated :)
