Option Explicit

' http://www.wordarticles.com/Shorts/RibbonVBA/RibbonVBADemo.php

' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' Definitions and Procedures relating to Accessibility, used by the Ribbon VBA  '
' Demonstration UserForm. The constants have been lifted from oleacc.h, and are '
' just a subset of those available.                                             '
'                                                (c) Tony Jollans, August 2008. '
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

Public Const CHILDID_SELF                  As Long = &H0&

Private Const STATE_SYSTEM_UNAVAILABLE     As Long = &H1&
Private Const STATE_SYSTEM_INVISIBLE       As Long = &H8000&
Private Const STATE_SYSTEM_SELECTED        As Long = &H2&

Public Enum RoleNumber
    ROLE_SYSTEM_CLIENT = &HA&
    ROLE_SYSTEM_PANE = &H10&
    ROLE_SYSTEM_GROUPING = &H14&
    ROLE_SYSTEM_TOOLBAR = &H16&
    ROLE_SYSTEM_PROPERTYPAGE = &H26&
    ROLE_SYSTEM_GRAPHIC = &H28&
    ROLE_SYSTEM_STATICTEXT = &H29&
    ROLE_SYSTEM_Text = &H2A&
    ROLE_SYSTEM_PAGETABLIST = &H3C&
End Enum

Private Enum NavigationDirection
    NAVDIR_FIRSTCHILD = &H7&
End Enum

#If Win64 Then
    Private Declare PtrSafe Function AccessibleChildren _
                Lib "oleacc.dll" _
                    (ByVal paccContainer As Object, _
                     ByVal iChildStart As Longlong, _
                     ByVal cChildren As Longlong, _
                           rgvarChildren As Variant, _
                           pcObtained As Longlong) As LongPtr
                
    Private Declare PtrSafe Function GetRoleText _
                Lib "oleacc.dll" _
                Alias "GetRoleTextA" _
                    (ByVal dwRole As Longlong, _
                           lpszRole As Any, _
                     ByVal cchRoleMax As Longlong) As LongPtr
#Else
    Private Declare Function AccessibleChildren _
                Lib "oleacc.dll" _
                    (ByVal paccContainer As Object, _
                     ByVal iChildStart As Long, _
                     ByVal cChildren As Long, _
                           rgvarChildren As Variant, _
                           pcObtained As Long) _
                As Long

    Private Declare Function GetRoleText _
                Lib "oleacc.dll" _
                Alias "GetRoleTextA" _
                    (ByVal dwRole As Long, _
                           lpszRole As Any, _
                     ByVal cchRoleMax As Long) _
                As Long
#End If

Public Type ChildList
    Objects()       As IAccessible
    Levels()        As Long
    SelectedIndex   As Long
End Type
    
Private Const NoControls As String = "(no available controls)"
Private Const ExecuteControl As String = "Execute selected Control"
Private Const NoExecuteControl As String = "Text control: can't execute"
‘…

Option Explicit

Const SEPARATORS As String = ";#"

Public Sub GotoWebLink(sURL As String, Optional vSeparator As Variant)
    
    Dim vItems As Variant
    Dim I As Long
    
    On Error GoTo ErrHandler
    
    ' Separator validation
    If IsMissing(vSeparator) Then vSeparator = ";"
    If Len(vSeparator) > 1 Then GoTo SeparatorError
    If InStr(SEPARATORS, vSeparator) = 0 Then GoTo SeparatorError
    
    ' URL, MailTo or Path validation
    If InStr(sURL, "/") = 0 And InStr(sURL, "\") = 0 And InStr(sURL, ":") = 0 Then
        If MsgBox("Is this URL valid? " & vbCrLf & vbCrLf & sURL, vbYesNo + vbQuestion, APP_TITLE) = vbNo Then Exit Sub
    End If
    
    'Split URLs if multiple
    vItems = Split(sURL, vSeparator)
    
    ' Launch URLs
    For I = LBound(vItems) To UBound(vItems)
        'No need to check for a valid internet connection
        If Val(Application.Version) = 12 Then
            ActiveWorkbook.FollowHyperlink CStr(vItems(I))
        Else
            ThisWorkbook.FollowHyperlink CStr(vItems(I))
        End If
    Next I
Exit Sub
    
ErrHandler:
    MsgBox "The requested webpage cannot be launched due to a web error" & vbCrLf & _
           "or due to a temporarily unavailable service." & vbCrLf & vbCrLf & _
           "Please try again later.", vbCritical, APP_TITLE
    Exit Sub
SeparatorError:
        MsgBox "Weblink separator error " & vSeparator, vbCritical, APP_TITLE
End Sub