Enum BrowserName

    'This Enum is part of Sub OpenURL()

    InternetExplorer = 1

    FireFox = 2

    Chrome = 3

    Opera = 4

End Enum

 

'---------------------------------------------------------------------------------------

' Procedure : OpenURL

' Author    : Daniel Pineault, CARDA Consultants Inc.

' Website   : http://www.cardaconsultants.com

' Purpose   : Open a URL in FireFox

' Copyright : The following is release as Attribution-ShareAlike 4.0 International

'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/

' Req'd Refs: Uses Late Binding, so none required

'

' Input Variables:

' ~~~~~~~~~~~~~~~~

' sURL      : URL to open in FifeFox

'

' Usage:

' ~~~~~~

' Call OpenURL("http://www.google.ca", InternetExplorer)

' Call OpenURL("devhut.net", Chrome)

' Call OpenURL("msdn.com", FireFox)

' Call OpenURL("google.ca",Opera)

'

' Revision History:

' Rev       Date(yyyy/mm/dd)        Description

' **************************************************************************************

' 1         2014-11-13              Initial Release

' 2         2018-02-01              Updated Copyright under CC licensing

'                                   Error trapped FireFox not installed

' 3         2018-02-01              Complete revamp of the code to accomodate multiple

'                                   Browser

'---------------------------------------------------------------------------------------

Sub OpenURL(ByVal sURL As String, ByVal lBrowser As BrowserName)

    On Error GoTo Error_Handler

    Dim WSHShell              As Object

    Dim sFFExe                As String     'Executable path/filename

    Dim sProgName             As String     'Name of the Executable program

    Dim sExe                  As String     'Excutable exe filename

    Dim sCmdLineSwitch        As String     'Command line switch

    Dim sShellCmd             As String     'Shell Command

 

    'Determine the Path to FF executable

    Select Case lBrowser

        Case 1

            'https://msdn.microsoft.com/en-us/library/hh826025(v=vs.85).aspx

            sProgName = "Internet Explorer"

            sExe = "IEXPLORE.EXE"

            sCmdLineSwitch = " "

        Case 2

            'https://developer.mozilla.org/en-US/docs/Mozilla/Command_Line_Options#Browser

            sProgName = "Mozilla Firefox"

            sExe = "Firefox.EXE"

            sCmdLineSwitch = " -new-tab "

        Case 3

            sProgName = "Google Chrome"

            sExe = "Chrome.exe"

            sCmdLineSwitch = " -tab "

        Case 4

            'http://www.opera.com/docs/switches/

            sProgName = "Opera"

            sExe = "opera.exe"

            sCmdLineSwitch = " "

    End Select

    Set WSHShell = CreateObject("WScript.Shell")

    sFFExe = WSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\" & _

                              "CurrentVersion\App Paths\" & sExe & "\")

    sFFExe = Replace(sFFExe, Chr(34), "")    'Special case for Opera?!

    'Open the URL

    sShellCmd = """" & sFFExe & """" & "" & sCmdLineSwitch & """" & sURL & """"

    Shell sShellCmd, vbHide

 

Error_Handler_Exit:

    On Error Resume Next

    If Not WSHShell Is Nothing Then Set WSHShell = Nothing

    Exit Sub

 

Error_Handler:

    If Err.Number = -2147024894 Then

        MsgBox sProgName & " does not appear to be installed on this compter", _

               vbInformation Or vbOKOnly, "Unable to open the requested URL"

    Else

        MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _

               "Error Number: " & Err.Number & vbCrLf & _

               "Error Source: OpenURL" & vbCrLf & _

               "Error Description: " & Err.Description & _

               Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _

               , vbOKOnly + vbCritical, "An Error has Occurred!"

    End If

    Resume Error_Handler_Exit

End Sub