Senso
Meubilair
- Lid geworden
- 13 jun 2016
- Berichten
- 9.666
- Besturingssysteem
- W10 Pro en W11 Pro
- Office versie
- Office 2007 H@S en Office 2021 Prof Plus
Code:
Enum BrowserName
'This Enum is part of Sub OpenURL()
' *** If changes are made here, update GetBrowserNameEnumValue()
iexplore = 1
firefox = 2
chrome = 3
opera = 4
msedge = 5
brave = 6
End Enum
'---------------------------------------------------------------------------------------
' Procedure : OpenURL
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Open a URL in a browser
' 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
' Dependencies: BrowserName Enum, GetDefaultBrowser(), GetBrowserNameEnumValue()
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sURL : URL to open
' lBrowser : Optional, browser to be used to open the URL, if omitted, the system's
' default browser will be used
'
' Usage:
' ~~~~~~
' Call OpenURL("https://www.google.ca", InternetExplorer)
' Call OpenURL("devhut.net", Chrome)
' Call OpenURL("msdn.com", FireFox)
' Call OpenURL("google.ca", Opera)
' Call OpenURL("https://www.google.ca", Edge)
' Call OpenURL("https://www.google.ca", Brave)
'
' 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
' 4 2020-04-27 Added Microsoft Edge
' Added Brave
' 5 2020-12-14 Adapted to now have lBrowser as optional and the
' ability to determine the system's default browser
'---------------------------------------------------------------------------------------
Sub OpenURL(ByVal sURL As String, Optional lBrowser As BrowserName)
Dim oShell 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
On Error GoTo Error_Handler
'If no browser is specified then use the system's default one
If lBrowser = 0 Then
lBrowser = GetBrowserNameEnumValue(GetDefaultBrowser())
End If
'Determine the Path to 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 = " "
Case 5
sProgName = "Microsoft Edge"
sExe = "Chrome.exe"
sCmdLineSwitch = " -tab "
Case 6
sProgName = "Brave"
sExe = "brave.exe"
sCmdLineSwitch = " -tab "
End Select
If lBrowser = 5 Then 'Special case for Edge! Thank you Microsoft for not following the rules!
'Build the command
sShellCmd = "cmd /c """ & "start microsoft-edge:" & sURL & """"
Else
Set oShell = CreateObject("WScript.Shell")
sFFExe = oShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\" & _
"CurrentVersion\App Paths\" & sExe & "\")
'Parse the returned string
sFFExe = Replace(sFFExe, Chr(34), "") 'Special case for Opera?!
'Build the command
sShellCmd = """" & sFFExe & """" & "" & sCmdLineSwitch & """" & sURL & """"
End If
'Open the URL
Shell sShellCmd, vbHide
Error_Handler_Exit:
On Error Resume Next
If Not oShell Is Nothing Then Set oShell = 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
Laatst bewerkt: