Opening URLs in new browser window

[Merri]

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?

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:

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

[Merri]

Well, I found more things behind this: the code does open up the link in a new browser, but only if there is no existing browser window. If there is, it just opens a new browser. I've tested only with Firebird, since I don't want to open IE