Change Office Theme with code

T

tiredofit

Well-known Member
Joined
Apr 11, 2013
Messages
1,924
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Is it possible to change the Office Theme via VBA?

Manually, the steps would be:

File -> Account -> Office Theme -> Dark Grey / Black / White/ Using system setting / Colourful

Thanks
 
Sort by date Sort by votes

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Hi @tiredofit

I seem to have managed to retrieve/change/apply the office themes via code using UIAutomation and legacy Accessibility. No extrenal references are required to be set in the vba project. Just plain, plug and play vba.

Since this uses UI automation, the code is language-sensitive. The code as is, should work with English, Spanish and French editions of office only.
To make this work with other languages, you will need to change the global constants declared at the top of the api module. I have placed the constants there for easier future editing.

File Demo:
OfficeThemes_VBA.xlsm

Tested in (xl 2013 x32) and (xl 2016 x64 ). I hope it works in Office 365.






1- API code in a bas Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
    Private Const PTR_LEN = 8&
#Else
    Private Const NULL_PTR = 0&
    Private Const PTR_LEN = 4&
#End If

Private Enum RoleSystems
    ROLE_SYSTEM_LISTITEM = 34&
    ROLE_SYSTEM_PUSHBUTTON = 43&
    ROLE_SYSTEM_COMBOBOX = 46&
End Enum

Private Enum TreeScope
    TreeScope_None = 0&
    TreeScope_Element = 1&
    TreeScope_Children = 2&
    TreeScope_Descendants = 4&
    TreeScope_Subtree = ((TreeScope_Element + TreeScope_Children) + TreeScope_Descendants)
End Enum

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0& To 7&) As Byte
End Type

#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
    Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
    Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#End If

Private arThemes() As String
Private sTheme As String
Private bFindAndApplyThemesRet As Boolean
Private bRetrievingThemes As Boolean

' ******************************************************************
'   This code is language sensitive !!!
'   Languages supported: (English - Spanish - French)
'   Constants for supported languages:
    Private Const LANG_OFFICE_THEME_LABEL = "OFFICE THEME: TEMA DE OFFICE: THÈME OFFICE:"
    Private Const LANG_OK_BUTTON = "OK ACEPTAR"
    Private Const LANG_CANCEL_BUTTON = "CANCEL CANCELAR ANNULER"
' ******************************************************************


Function GetAvailableOfficeThemes() As String()

    Const WH_CBT = 5&
    Dim lHook As LongPtr
 
    If OfficeThemesExist = False Then GoTo WrongOfficeVersion
 
    bRetrievingThemes = True
    Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
    lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, NULL_PTR, GetCurrentThreadId)
    Call SetProp(Application.hwnd, "Hook", lHook)
    Application.CommandBars.ExecuteMso ("ApplicationOptionsDialog")
    Call RemoveProp(Application.hwnd, "Hook")
    bRetrievingThemes = False
    GetAvailableOfficeThemes = arThemes
    Erase arThemes
    Exit Function
 
WrongOfficeVersion:
    MsgBox "Office themes are only availble in editions greater than 2007.", vbCritical, "Error"

End Function

Function ApplyOfficeTheme(ByVal ThemeName As String) As Boolean

    Const WH_CBT = 5&
    Dim lHook As LongPtr
 
    If OfficeThemesExist = False Then GoTo WrongOfficeVersion
 
    sTheme = ThemeName
    bFindAndApplyThemesRet = False
    Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
    lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, NULL_PTR, GetCurrentThreadId)
    Call SetProp(Application.hwnd, "Hook", lHook)
    Application.CommandBars.ExecuteMso ("ApplicationOptionsDialog")
    Call RemoveProp(Application.hwnd, "Hook")
    sTheme = ""
    ApplyOfficeTheme = bFindAndApplyThemesRet 'FindAndApplyThemes
    Exit Function
 
WrongOfficeVersion:
    MsgBox "Office themes are only availble in editions greater than 2007.", vbCritical, "Error"

End Function


' _____________________________________ PRIVATE ROUTINES _____________________________________________

Private Function HookProc( _
    ByVal idHook As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr _
) As LongPtr

    Const HC_ACTION = 0&, HCBT_CREATEWND = 3&, HCBT_ACTIVATE = 5&, GW_CHILD = 5&
    Dim sBuff As String * 256&, lRet As Long
 
    If idHook < HC_ACTION Then
        HookProc = CallNextHookEx(GetProp(Application.hwnd, "Hook"), idHook, wParam, lParam)
        Exit Function
    End If
 
    If idHook = HCBT_CREATEWND Then
        Call SetTimer(Application.hwnd, NULL_PTR, 1000&, AddressOf UnHookJustInCase)
    End If
 
    If idHook = HCBT_ACTIVATE Then
        lRet = GetClassName(wParam, sBuff, 256&)
        If Left(sBuff, lRet) = "NUIDialog" Then
            Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
            Call FindAndApplyThemes(GetNextWindow(wParam, GW_CHILD), TreeScope_Subtree)
        End If
    End If

End Function

Private Sub UnHookJustInCase()
    On Error Resume Next
    Call KillTimer(Application.hwnd, NULL_PTR)
    Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
    Call RemoveProp(Application.hwnd, "Hook")
End Sub


Private Sub FindAndApplyThemes( _
    ByVal hwnd As LongPtr, _
    Optional ByVal Scope As TreeScope = TreeScope_Subtree _
)
    Const UIA_LegacyIAccessiblePatternId = 10018&
    Const IID_IUIAutomationLegacyIAccessiblePattern = "{828055ad-355b-4435-86d5-3b51c14a9b1b}"
    Const SELFLAG_TAKEFOCUS = 1&, SELFLAG_TAKESELECTION = 2&
    Dim iidCuiAuto As GUID
    Dim lIndex As Long, lElementsCount As Long
    Dim j As Long, k As Long, lSelectionFlag As Long
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long
    Dim sName As String, sValue As String, lRole As Long, lChildCount As Long
    Dim pAutomation As LongPtr, pPattern As LongPtr, pElement As LongPtr
    Dim pElementArray As LongPtr, pChildrenArray As LongPtr, pTrueCond As LongPtr
    Dim pChildElement As LongPtr
    Dim pLegacyName As LongPtr, pValue As LongPtr
    Dim pOk As LongPtr, pCancel As LongPtr, pThemeCombo As LongPtr
 
 
    pAutomation = GetAutomationPtr
    If pAutomation = NULL_PTR Then MsgBox "Automation failed.": Exit Sub
 
    vFuncOrdinal = 6& ' IUIAutomation::ElementFromHandle
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pAutomation, vTblOffset, vbLong, hwnd, VarPtr(pElement))
 
    vFuncOrdinal = 21& ' IUIAutomation::CreateTrueCondition
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pAutomation, vTblOffset, vbLong, VarPtr(pTrueCond))
 
    vFuncOrdinal = 6& ' IUIAutomationElement::FindAll
    vTblOffset = vFuncOrdinal * PTR_LEN ' IUIAutomationElement::FindAll
    lRet = vtblStdCall(pElement, vTblOffset, vbLong, Scope, pTrueCond, VarPtr(pElementArray))

    vFuncOrdinal = 3& ' IUIAutomationElementArray :get_Length
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pElementArray, vTblOffset, vbLong, VarPtr(lElementsCount))

    If lElementsCount = 0& Then
        GoTo Release_Interfaces
    End If
 
    lRet = CLSIDFromString(StrPtr(IID_IUIAutomationLegacyIAccessiblePattern), iidCuiAuto)
    Call DispGUID(iidCuiAuto)
 
    For lIndex = 0& To lElementsCount - 1&
 
        vFuncOrdinal = 4& ' IUIAutomationElementArray :GetElement
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pElementArray, vTblOffset, vbLong, lIndex, VarPtr(pElement))
     
        vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pElement, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))
   
        If pPattern <> NULL_PTR Then
         
            'Retrieve descendants properties.
            vFuncOrdinal = 7& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentName
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(pLegacyName))
            sName = GetStrFromPtrW(pLegacyName)
         
            vFuncOrdinal = 10& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentRole
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(lRole))
'            lRl = lRole
         
            vFuncOrdinal = 8& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentValue
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(pValue))
            sValue = GetStrFromPtrW(pValue)
   
            Select Case True
                Case InStr(LANG_OK_BUTTON, UCase(sName)) And lRole = ROLE_SYSTEM_PUSHBUTTON
                    pOk = pElement
                Case InStr(LANG_CANCEL_BUTTON, UCase(sName)) And lRole = ROLE_SYSTEM_PUSHBUTTON
                    pCancel = pElement
                Case InStr(LANG_OFFICE_THEME_LABEL, UCase(sName)) And lRole = ROLE_SYSTEM_COMBOBOX
                    pThemeCombo = pElement
            End Select
         
        End If
     
        vFuncOrdinal = 2& 'IUIAutomationElement::Release
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pElement, vTblOffset, vbLong)
     
    Next lIndex
     
     
    vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pThemeCombo, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))

    vFuncOrdinal = 4& 'IID_IUIAutomationLegacyIAccessiblePattern::DoDefaultAction
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pPattern, vTblOffset, vbLong)
 
    'Retrieve ChildCount.
    vFuncOrdinal = 6& ' IUIAutomationElement::FindAll
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pThemeCombo, vTblOffset, vbLong, TreeScope_Subtree, pTrueCond, VarPtr(pChildrenArray))

    vFuncOrdinal = 3& ' IUIAutomationElementArray :get_Length
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pChildrenArray, vTblOffset, vbLong, VarPtr(lChildCount))

    If lChildCount = 0& Then
        GoTo Release_Interfaces
    End If

    For j = 0& To lChildCount - 1&
         
        vFuncOrdinal = 4& ' IUIAutomationElementArray :GetElement
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pChildrenArray, vTblOffset, vbLong, j, VarPtr(pChildElement))

        vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pChildElement, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))

        vFuncOrdinal = 7& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentName
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(pValue))
        sValue = GetStrFromPtrW(pValue)
         
        vFuncOrdinal = 10& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentRole
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(lRole))
'        lRl = lRole
         
        If lRole = ROLE_SYSTEM_LISTITEM And bRetrievingThemes Then
            ReDim Preserve arThemes(k)
            arThemes(k) = sValue:  k = k + 1&
        End If

        If lRole = ROLE_SYSTEM_LISTITEM And bRetrievingThemes = False Then
     
            If UCase(sValue) = UCase(sTheme) Then
         
                lSelectionFlag = SELFLAG_TAKEFOCUS + SELFLAG_TAKESELECTION
                vFuncOrdinal = 3& 'IUIAutomationLegacyIAccessiblePattern::Select
                vTblOffset = vFuncOrdinal * PTR_LEN
                lRet = vtblStdCall(pPattern, vTblOffset, vbLong, lSelectionFlag)

                vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
                vTblOffset = vFuncOrdinal * PTR_LEN
                lRet = vtblStdCall(pOk, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))

                vFuncOrdinal = 4& 'IID_IUIAutomationLegacyIAccessiblePattern::DoDefaultAction
                vTblOffset = vFuncOrdinal * PTR_LEN
                lRet = vtblStdCall(pPattern, vTblOffset, vbLong)
             
                bFindAndApplyThemesRet = True '< set global flag to indicate success
                GoTo Release_Interfaces
                 
            End If
             
        End If

        vFuncOrdinal = 2& 'IUIAutomationLegacyIAccessiblePattern::Release
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pPattern, vTblOffset, vbLong)

        vFuncOrdinal = 2& 'IUIAutomationElement::Release
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pChildElement, vTblOffset, vbLong) 'IUIAutomationElementArray ::Release

    Next j
 
    vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pCancel, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))

    vFuncOrdinal = 4& 'IID_IUIAutomationLegacyIAccessiblePattern::DoDefaultAction
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pPattern, vTblOffset, vbLong)
     
Release_Interfaces:
 
    vFuncOrdinal = 2& 'Release
    vTblOffset = vFuncOrdinal * PTR_LEN
    If pAutomation Then
        lRet = vtblStdCall(pChildrenArray, vTblOffset, vbLong) 'IUIAutomationElementArray::Release
        lRet = vtblStdCall(pTrueCond, vTblOffset, vbLong) 'IUIAutomationCondition ::Release
        lRet = vtblStdCall(pElementArray, vTblOffset, vbLong) 'IUIAutomationElementArray ::Release
        lRet = vtblStdCall(pAutomation, vTblOffset, vbLong) 'IUIAutomation::Release
    End If
 
End Sub

Private Function GetAutomationPtr() As LongPtr
    Dim pAutomation As LongPtr
    Const IID_CUIAUTOMATION = "{FF48DBA4-60EF-4201-AA87-54103EEF594E}"
    Const IID_IUIAUTOMATION = "{30CBE57D-D9D0-452A-AB13-7AC5AC4825EE}"
    Const CLSCTX_INPROC_SERVER = &H1, CC_STDCALL = 4&, S_OK = 0&
    Dim iidCuiAuto As GUID, iidIuiAuto As GUID, lRet As Long
    lRet = CLSIDFromString(StrPtr(IID_CUIAUTOMATION), iidCuiAuto)
    Call DispGUID(iidCuiAuto)
    lRet = CLSIDFromString(StrPtr(IID_IUIAUTOMATION), iidIuiAuto)
    Call DispGUID(iidIuiAuto)
    lRet = CoCreateInstance(iidCuiAuto, NULL_PTR, CLSCTX_INPROC_SERVER, iidIuiAuto, pAutomation)
    If lRet = S_OK Then GetAutomationPtr = pAutomation
End Function

Private Function vtblStdCall( _
    ByVal InterfacePointer As LongPtr, _
    ByVal VTableOffset As Long, _
    ByVal FunctionReturnType As Long, _
    ParamArray FunctionParameters() As Variant _
) As Variant

    Const CC_STDCALL = 4&
    Dim vParamPtr() As LongPtr
    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0& To 0&)
        ReDim vParamType(0& To 0&)
    Else
        ReDim vParamPtr(0& To pCount - 1&)
        ReDim vParamType(0& To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc( _
                InterfacePointer, VTableOffset, CC_STDCALL, FunctionReturnType, _
                pCount, vParamType(0&), vParamPtr(0&), vRtn)

    If pIndex = 0& Then
        vtblStdCall = vRtn
    Else
        Call SetLastError(pIndex)
    End If
 
End Function

Private Sub DispGUID(objGuid As GUID)
    Dim lRet As Long, sTmp As String, buf(100&) As Byte
    lRet = StringFromGUID2(objGuid, VarPtr(buf(0&)), UBound(buf) - 1&)
    sTmp = buf
End Sub

Private Function GetStrFromPtrW(ByVal lpString As LongPtr) As String
   Dim lLength As Long, sBuffer As String
   lLength = lstrlen(lpString)
   sBuffer = Space$(lLength)
   Call CopyMemory(ByVal StrPtr(sBuffer), ByVal lpString, lLength * 2&)
   GetStrFromPtrW = sBuffer
End Function

Private Function OfficeThemesExist() As Boolean
    OfficeThemesExist = CBool(Val(Application.Version) >= 12&) ' office>=2007
End Function



2- Code Usage example in the UserForm Module:
VBA Code: 
Option Explicit

Private Sub UserForm_Initialize()
    Dim arThemes() As String
    arThemes = GetAvailableOfficeThemes
    If Not Not arThemes Then
        ComboBox1.List = arThemes
        ComboBox1.ListIndex = 0&
    End If
End Sub

Private Sub CommandButton1_Click()
    If ApplyOfficeTheme(ComboBox1.Value) Then
        'success
    Else
        'Failure
    End If
End Sub
 
Upvote 0
Jaafar Tribak said:
Hi @tiredofit

I seem to have managed to retrieve/change/apply the office themes via code using UIAutomation and legacy Accessibility. No extrenal references are required to be set in the vba project. Just plain, plug and play vba.

Since this uses UI automation, the code is language-sensitive. The code as is, should work with English, Spanish and French editions of office only.
To make this work with other languages, you will need to change the global constants declared at the top of the api module. I have placed the constants there for easier future editing.

File Demo:
OfficeThemes_VBA.xlsm

Tested in (xl 2013 x32) and (xl 2016 x64 ). I hope it works in Office 365.






1- API code in a bas Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
    Private Const PTR_LEN = 8&
#Else
    Private Const NULL_PTR = 0&
    Private Const PTR_LEN = 4&
#End If

Private Enum RoleSystems
    ROLE_SYSTEM_LISTITEM = 34&
    ROLE_SYSTEM_PUSHBUTTON = 43&
    ROLE_SYSTEM_COMBOBOX = 46&
End Enum

Private Enum TreeScope
    TreeScope_None = 0&
    TreeScope_Element = 1&
    TreeScope_Children = 2&
    TreeScope_Descendants = 4&
    TreeScope_Subtree = ((TreeScope_Element + TreeScope_Children) + TreeScope_Descendants)
End Enum

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0& To 7&) As Byte
End Type

#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
    Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
    Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#End If

Private arThemes() As String
Private sTheme As String
Private bFindAndApplyThemesRet As Boolean
Private bRetrievingThemes As Boolean

' ******************************************************************
'   This code is language sensitive !!!
'   Languages supoorted: (English - Spanish - French)
'   Constants for supported languages:
    Private Const LANG_OFFICE_THEME_LABEL = "OFFICE THEME: TEMA DE OFFICE: THÈME OFFICE:"
    Private Const LANG_OK_BUTTON = "OK ACEPTAR"
    Private Const LANG_CANCEL_BUTTON = "CANCEL CANCELAR ANNULER"
' ******************************************************************


Function GetAvailableOfficeThemes() As String()

    Const WH_CBT = 5&
    Dim lHook As LongPtr
 
    If OfficeThemesExist = False Then GoTo WrongOfficeVersion
 
    bRetrievingThemes = True
    Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
    lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, NULL_PTR, GetCurrentThreadId)
    Call SetProp(Application.hwnd, "Hook", lHook)
    Application.CommandBars.ExecuteMso ("ApplicationOptionsDialog")
    Call RemoveProp(Application.hwnd, "Hook")
    bRetrievingThemes = False
    GetAvailableOfficeThemes = arThemes
    Erase arThemes
    Exit Function
 
WrongOfficeVersion:
    MsgBox "Office themes are only availble in editions greater than 2007.", vbCritical, "Error"

End Function

Function ApplyOfficeTheme(ByVal ThemeName As String) As Boolean

    Const WH_CBT = 5&
    Dim lHook As LongPtr
 
    If OfficeThemesExist = False Then GoTo WrongOfficeVersion
 
    sTheme = ThemeName
    bFindAndApplyThemesRet = False
    Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
    lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, NULL_PTR, GetCurrentThreadId)
    Call SetProp(Application.hwnd, "Hook", lHook)
    Application.CommandBars.ExecuteMso ("ApplicationOptionsDialog")
    Call RemoveProp(Application.hwnd, "Hook")
    sTheme = ""
    ApplyOfficeTheme = bFindAndApplyThemesRet 'FindAndApplyThemes
    Exit Function
 
WrongOfficeVersion:
    MsgBox "Office themes are only availble in editions greater than 2007.", vbCritical, "Error"

End Function


' _____________________________________ PRIVATE ROUTINES _____________________________________________

Private Function HookProc( _
    ByVal idHook As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr _
) As LongPtr

    Const HC_ACTION = 0&, HCBT_CREATEWND = 3&, HCBT_ACTIVATE = 5&, GW_CHILD = 5&
    Dim sBuff As String * 256&, lRet As Long
 
    If idHook < HC_ACTION Then
        HookProc = CallNextHookEx(GetProp(Application.hwnd, "Hook"), idHook, wParam, lParam)
        Exit Function
    End If
 
    If idHook = HCBT_CREATEWND Then
        Call SetTimer(Application.hwnd, NULL_PTR, 1000&, AddressOf UnHookJustInCase)
    End If
 
    If idHook = HCBT_ACTIVATE Then
        lRet = GetClassName(wParam, sBuff, 256&)
        If Left(sBuff, lRet) = "NUIDialog" Then
            Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
            Call FindAndApplyThemes(GetNextWindow(wParam, GW_CHILD), TreeScope_Subtree)
        End If
    End If

End Function

Private Sub UnHookJustInCase()
    On Error Resume Next
    Call KillTimer(Application.hwnd, NULL_PTR)
    Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
    Call RemoveProp(Application.hwnd, "Hook")
End Sub


Private Sub FindAndApplyThemes( _
    ByVal hwnd As LongPtr, _
    Optional ByVal Scope As TreeScope = TreeScope_Subtree _
)
    Const UIA_LegacyIAccessiblePatternId = 10018&
    Const IID_IUIAutomationLegacyIAccessiblePattern = "{828055ad-355b-4435-86d5-3b51c14a9b1b}"
    Const SELFLAG_TAKEFOCUS = 1&, SELFLAG_TAKESELECTION = 2&
    Dim iidCuiAuto As GUID
    Dim lIndex As Long, lElementsCount As Long
    Dim j As Long, k As Long, lSelectionFlag As Long
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long
    Dim sName As String, sValue As String, lRole As Long, lChildCount As Long
    Dim pAutomation As LongPtr, pPattern As LongPtr, pElement As LongPtr
    Dim pElementArray As LongPtr, pChildrenArray As LongPtr, pTrueCond As LongPtr
    Dim pChildElement As LongPtr
    Dim pLegacyName As LongPtr, pValue As LongPtr
    Dim pOk As LongPtr, pCancel As LongPtr, pThemeCombo As LongPtr
 
 
    pAutomation = GetAutomationPtr
    If pAutomation = NULL_PTR Then MsgBox "Automation failed.": Exit Sub
 
    vFuncOrdinal = 6& ' IUIAutomation::ElementFromHandle
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pAutomation, vTblOffset, vbLong, hwnd, VarPtr(pElement))
 
    vFuncOrdinal = 21& ' IUIAutomation::CreateTrueCondition
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pAutomation, vTblOffset, vbLong, VarPtr(pTrueCond))
 
    vFuncOrdinal = 6& ' IUIAutomationElement::FindAll
    vTblOffset = vFuncOrdinal * PTR_LEN ' IUIAutomationElement::FindAll
    lRet = vtblStdCall(pElement, vTblOffset, vbLong, Scope, pTrueCond, VarPtr(pElementArray))

    vFuncOrdinal = 3& ' IUIAutomationElementArray :get_Length
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pElementArray, vTblOffset, vbLong, VarPtr(lElementsCount))

    If lElementsCount = 0& Then
        GoTo Release_Interfaces
    End If
 
    lRet = CLSIDFromString(StrPtr(IID_IUIAutomationLegacyIAccessiblePattern), iidCuiAuto)
    Call DispGUID(iidCuiAuto)
 
    For lIndex = 0& To lElementsCount - 1&
 
        vFuncOrdinal = 4& ' IUIAutomationElementArray :GetElement
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pElementArray, vTblOffset, vbLong, lIndex, VarPtr(pElement))
     
        vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pElement, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))
   
        If pPattern <> NULL_PTR Then
         
            'Retrieve descendants properties.
            vFuncOrdinal = 7& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentName
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(pLegacyName))
            sName = GetStrFromPtrW(pLegacyName)
         
            vFuncOrdinal = 10& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentRole
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(lRole))
'            lRl = lRole
         
            vFuncOrdinal = 8& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentValue
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(pValue))
            sValue = GetStrFromPtrW(pValue)
   
            Select Case True
                Case InStr(LANG_OK_BUTTON, UCase(sName)) And lRole = ROLE_SYSTEM_PUSHBUTTON
                    pOk = pElement
                Case InStr(LANG_CANCEL_BUTTON, UCase(sName)) And lRole = ROLE_SYSTEM_PUSHBUTTON
                    pCancel = pElement
                Case InStr(LANG_OFFICE_THEME_LABEL, UCase(sName)) And lRole = ROLE_SYSTEM_COMBOBOX
                    pThemeCombo = pElement
            End Select
         
        End If
     
        vFuncOrdinal = 2& 'IUIAutomationElement::Release
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pElement, vTblOffset, vbLong)
     
    Next lIndex
     
     
    vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pThemeCombo, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))

    vFuncOrdinal = 4& 'IID_IUIAutomationLegacyIAccessiblePattern::DoDefaultAction
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pPattern, vTblOffset, vbLong)
 
    'Retrieve ChildCount.
    vFuncOrdinal = 6& ' IUIAutomationElement::FindAll
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pThemeCombo, vTblOffset, vbLong, TreeScope_Subtree, pTrueCond, VarPtr(pChildrenArray))

    vFuncOrdinal = 3& ' IUIAutomationElementArray :get_Length
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pChildrenArray, vTblOffset, vbLong, VarPtr(lChildCount))

    If lChildCount = 0& Then
        GoTo Release_Interfaces
    End If

    For j = 0& To lChildCount - 1&
         
        vFuncOrdinal = 4& ' IUIAutomationElementArray :GetElement
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pChildrenArray, vTblOffset, vbLong, j, VarPtr(pChildElement))

        vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pChildElement, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))

        vFuncOrdinal = 7& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentName
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(pValue))
        sValue = GetStrFromPtrW(pValue)
         
        vFuncOrdinal = 10& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentRole
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(lRole))
'        lRl = lRole
         
        If lRole = ROLE_SYSTEM_LISTITEM And bRetrievingThemes Then
            ReDim Preserve arThemes(k)
            arThemes(k) = sValue:  k = k + 1&
        End If

        If lRole = ROLE_SYSTEM_LISTITEM And bRetrievingThemes = False Then
     
            If UCase(sValue) = UCase(sTheme) Then
         
                lSelectionFlag = SELFLAG_TAKEFOCUS + SELFLAG_TAKESELECTION
                vFuncOrdinal = 3& 'IUIAutomationLegacyIAccessiblePattern::Select
                vTblOffset = vFuncOrdinal * PTR_LEN
                lRet = vtblStdCall(pPattern, vTblOffset, vbLong, lSelectionFlag)

                vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
                vTblOffset = vFuncOrdinal * PTR_LEN
                lRet = vtblStdCall(pOk, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))

                vFuncOrdinal = 4& 'IID_IUIAutomationLegacyIAccessiblePattern::DoDefaultAction
                vTblOffset = vFuncOrdinal * PTR_LEN
                lRet = vtblStdCall(pPattern, vTblOffset, vbLong)
             
                bFindAndApplyThemesRet = True '< set global flag to indicate success
                GoTo Release_Interfaces
                 
            End If
             
        End If

        vFuncOrdinal = 2& 'IUIAutomationLegacyIAccessiblePattern::Release
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pPattern, vTblOffset, vbLong)

        vFuncOrdinal = 2& 'IUIAutomationElement::Release
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pChildElement, vTblOffset, vbLong) 'IUIAutomationElementArray ::Release

    Next j
 
    vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pCancel, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))

    vFuncOrdinal = 4& 'IID_IUIAutomationLegacyIAccessiblePattern::DoDefaultAction
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pPattern, vTblOffset, vbLong)
     
Release_Interfaces:
 
    vFuncOrdinal = 2& 'Release
    vTblOffset = vFuncOrdinal * PTR_LEN
    If pAutomation Then
        lRet = vtblStdCall(pChildrenArray, vTblOffset, vbLong) 'IUIAutomationElementArray::Release
        lRet = vtblStdCall(pTrueCond, vTblOffset, vbLong) 'IUIAutomationCondition ::Release
        lRet = vtblStdCall(pElementArray, vTblOffset, vbLong) 'IUIAutomationElementArray ::Release
        lRet = vtblStdCall(pAutomation, vTblOffset, vbLong) 'IUIAutomation::Release
    End If
 
End Sub

Private Function GetAutomationPtr() As LongPtr
    Dim pAutomation As LongPtr
    Const IID_CUIAUTOMATION = "{FF48DBA4-60EF-4201-AA87-54103EEF594E}"
    Const IID_IUIAUTOMATION = "{30CBE57D-D9D0-452A-AB13-7AC5AC4825EE}"
    Const CLSCTX_INPROC_SERVER = &H1, CC_STDCALL = 4&, S_OK = 0&
    Dim iidCuiAuto As GUID, iidIuiAuto As GUID, lRet As Long
    lRet = CLSIDFromString(StrPtr(IID_CUIAUTOMATION), iidCuiAuto)
    Call DispGUID(iidCuiAuto)
    lRet = CLSIDFromString(StrPtr(IID_IUIAUTOMATION), iidIuiAuto)
    Call DispGUID(iidIuiAuto)
    lRet = CoCreateInstance(iidCuiAuto, NULL_PTR, CLSCTX_INPROC_SERVER, iidIuiAuto, pAutomation)
    If lRet = S_OK Then GetAutomationPtr = pAutomation
End Function

Private Function vtblStdCall( _
    ByVal InterfacePointer As LongPtr, _
    ByVal VTableOffset As Long, _
    ByVal FunctionReturnType As Long, _
    ParamArray FunctionParameters() As Variant _
) As Variant

    Const CC_STDCALL = 4&
    Dim vParamPtr() As LongPtr
    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0& To 0&)
        ReDim vParamType(0& To 0&)
    Else
        ReDim vParamPtr(0& To pCount - 1&)
        ReDim vParamType(0& To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc( _
                InterfacePointer, VTableOffset, CC_STDCALL, FunctionReturnType, _
                pCount, vParamType(0&), vParamPtr(0&), vRtn)

    If pIndex = 0& Then
        vtblStdCall = vRtn
    Else
        Call SetLastError(pIndex)
    End If
 
End Function

Private Sub DispGUID(objGuid As GUID)
    Dim lRet As Long, sTmp As String, buf(100&) As Byte
    lRet = StringFromGUID2(objGuid, VarPtr(buf(0&)), UBound(buf) - 1&)
    sTmp = buf
End Sub

Private Function GetStrFromPtrW(ByVal lpString As LongPtr) As String
   Dim lLength As Long, sBuffer As String
   lLength = lstrlen(lpString)
   sBuffer = Space$(lLength)
   Call CopyMemory(ByVal StrPtr(sBuffer), ByVal lpString, lLength * 2&)
   GetStrFromPtrW = sBuffer
End Function

Private Function OfficeThemesExist() As Boolean
    OfficeThemesExist = CBool(Val(Application.Version) >= 12&) ' office>=2007
End Function



2- Code Usage example in the UserForm Module:
VBA Code: 
Option Explicit

Private Sub UserForm_Initialize()
    Dim arThemes() As String
    arThemes = GetAvailableOfficeThemes
    If Not Not arThemes Then
        ComboBox1.List = arThemes
        ComboBox1.ListIndex = 0&
    End If
End Sub

Private Sub CommandButton1_Click()
    If ApplyOfficeTheme(ComboBox1.Value) Then
        'success
    Else
        'Failure
    End If
End Sub
Click to expand...
This is great, just what I was seeking.

Thanks for uploading it.

Hope others can make use of it too.
 
Upvote 0
Jaafar Tribak said:
Hi @tiredofit

I seem to have managed to retrieve/change/apply the office themes via code using UIAutomation and legacy Accessibility. No extrenal references are required to be set in the vba project. Just plain, plug and play vba.

Since this uses UI automation, the code is language-sensitive. The code as is, should work with English, Spanish and French editions of office only.
To make this work with other languages, you will need to change the global constants declared at the top of the api module. I have placed the constants there for easier future editing.

File Demo:
OfficeThemes_VBA.xlsm

Tested in (xl 2013 x32) and (xl 2016 x64 ). I hope it works in Office 365.






1- API code in a bas Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
    Private Const PTR_LEN = 8&
#Else
    Private Const NULL_PTR = 0&
    Private Const PTR_LEN = 4&
#End If

Private Enum RoleSystems
    ROLE_SYSTEM_LISTITEM = 34&
    ROLE_SYSTEM_PUSHBUTTON = 43&
    ROLE_SYSTEM_COMBOBOX = 46&
End Enum

Private Enum TreeScope
    TreeScope_None = 0&
    TreeScope_Element = 1&
    TreeScope_Children = 2&
    TreeScope_Descendants = 4&
    TreeScope_Subtree = ((TreeScope_Element + TreeScope_Children) + TreeScope_Descendants)
End Enum

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0& To 7&) As Byte
End Type

#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
    Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
    Private Declare Function StringFromGUID2 Lib "ole32" (ByRef rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As GUID) As Long
    Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#End If

Private arThemes() As String
Private sTheme As String
Private bFindAndApplyThemesRet As Boolean
Private bRetrievingThemes As Boolean

' ******************************************************************
'   This code is language sensitive !!!
'   Languages supported: (English - Spanish - French)
'   Constants for supported languages:
    Private Const LANG_OFFICE_THEME_LABEL = "OFFICE THEME: TEMA DE OFFICE: THÈME OFFICE:"
    Private Const LANG_OK_BUTTON = "OK ACEPTAR"
    Private Const LANG_CANCEL_BUTTON = "CANCEL CANCELAR ANNULER"
' ******************************************************************


Function GetAvailableOfficeThemes() As String()

    Const WH_CBT = 5&
    Dim lHook As LongPtr
 
    If OfficeThemesExist = False Then GoTo WrongOfficeVersion
 
    bRetrievingThemes = True
    Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
    lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, NULL_PTR, GetCurrentThreadId)
    Call SetProp(Application.hwnd, "Hook", lHook)
    Application.CommandBars.ExecuteMso ("ApplicationOptionsDialog")
    Call RemoveProp(Application.hwnd, "Hook")
    bRetrievingThemes = False
    GetAvailableOfficeThemes = arThemes
    Erase arThemes
    Exit Function
 
WrongOfficeVersion:
    MsgBox "Office themes are only availble in editions greater than 2007.", vbCritical, "Error"

End Function

Function ApplyOfficeTheme(ByVal ThemeName As String) As Boolean

    Const WH_CBT = 5&
    Dim lHook As LongPtr
 
    If OfficeThemesExist = False Then GoTo WrongOfficeVersion
 
    sTheme = ThemeName
    bFindAndApplyThemesRet = False
    Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
    lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, NULL_PTR, GetCurrentThreadId)
    Call SetProp(Application.hwnd, "Hook", lHook)
    Application.CommandBars.ExecuteMso ("ApplicationOptionsDialog")
    Call RemoveProp(Application.hwnd, "Hook")
    sTheme = ""
    ApplyOfficeTheme = bFindAndApplyThemesRet 'FindAndApplyThemes
    Exit Function
 
WrongOfficeVersion:
    MsgBox "Office themes are only availble in editions greater than 2007.", vbCritical, "Error"

End Function


' _____________________________________ PRIVATE ROUTINES _____________________________________________

Private Function HookProc( _
    ByVal idHook As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr _
) As LongPtr

    Const HC_ACTION = 0&, HCBT_CREATEWND = 3&, HCBT_ACTIVATE = 5&, GW_CHILD = 5&
    Dim sBuff As String * 256&, lRet As Long
 
    If idHook < HC_ACTION Then
        HookProc = CallNextHookEx(GetProp(Application.hwnd, "Hook"), idHook, wParam, lParam)
        Exit Function
    End If
 
    If idHook = HCBT_CREATEWND Then
        Call SetTimer(Application.hwnd, NULL_PTR, 1000&, AddressOf UnHookJustInCase)
    End If
 
    If idHook = HCBT_ACTIVATE Then
        lRet = GetClassName(wParam, sBuff, 256&)
        If Left(sBuff, lRet) = "NUIDialog" Then
            Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
            Call FindAndApplyThemes(GetNextWindow(wParam, GW_CHILD), TreeScope_Subtree)
        End If
    End If

End Function

Private Sub UnHookJustInCase()
    On Error Resume Next
    Call KillTimer(Application.hwnd, NULL_PTR)
    Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook"))
    Call RemoveProp(Application.hwnd, "Hook")
End Sub


Private Sub FindAndApplyThemes( _
    ByVal hwnd As LongPtr, _
    Optional ByVal Scope As TreeScope = TreeScope_Subtree _
)
    Const UIA_LegacyIAccessiblePatternId = 10018&
    Const IID_IUIAutomationLegacyIAccessiblePattern = "{828055ad-355b-4435-86d5-3b51c14a9b1b}"
    Const SELFLAG_TAKEFOCUS = 1&, SELFLAG_TAKESELECTION = 2&
    Dim iidCuiAuto As GUID
    Dim lIndex As Long, lElementsCount As Long
    Dim j As Long, k As Long, lSelectionFlag As Long
    Dim lRet As Long, vTblOffset As Long, vFuncOrdinal As Long
    Dim sName As String, sValue As String, lRole As Long, lChildCount As Long
    Dim pAutomation As LongPtr, pPattern As LongPtr, pElement As LongPtr
    Dim pElementArray As LongPtr, pChildrenArray As LongPtr, pTrueCond As LongPtr
    Dim pChildElement As LongPtr
    Dim pLegacyName As LongPtr, pValue As LongPtr
    Dim pOk As LongPtr, pCancel As LongPtr, pThemeCombo As LongPtr
 
 
    pAutomation = GetAutomationPtr
    If pAutomation = NULL_PTR Then MsgBox "Automation failed.": Exit Sub
 
    vFuncOrdinal = 6& ' IUIAutomation::ElementFromHandle
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pAutomation, vTblOffset, vbLong, hwnd, VarPtr(pElement))
 
    vFuncOrdinal = 21& ' IUIAutomation::CreateTrueCondition
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pAutomation, vTblOffset, vbLong, VarPtr(pTrueCond))
 
    vFuncOrdinal = 6& ' IUIAutomationElement::FindAll
    vTblOffset = vFuncOrdinal * PTR_LEN ' IUIAutomationElement::FindAll
    lRet = vtblStdCall(pElement, vTblOffset, vbLong, Scope, pTrueCond, VarPtr(pElementArray))

    vFuncOrdinal = 3& ' IUIAutomationElementArray :get_Length
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pElementArray, vTblOffset, vbLong, VarPtr(lElementsCount))

    If lElementsCount = 0& Then
        GoTo Release_Interfaces
    End If
 
    lRet = CLSIDFromString(StrPtr(IID_IUIAutomationLegacyIAccessiblePattern), iidCuiAuto)
    Call DispGUID(iidCuiAuto)
 
    For lIndex = 0& To lElementsCount - 1&
 
        vFuncOrdinal = 4& ' IUIAutomationElementArray :GetElement
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pElementArray, vTblOffset, vbLong, lIndex, VarPtr(pElement))
    
        vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pElement, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))
  
        If pPattern <> NULL_PTR Then
        
            'Retrieve descendants properties.
            vFuncOrdinal = 7& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentName
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(pLegacyName))
            sName = GetStrFromPtrW(pLegacyName)
        
            vFuncOrdinal = 10& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentRole
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(lRole))
'            lRl = lRole
        
            vFuncOrdinal = 8& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentValue
            vTblOffset = vFuncOrdinal * PTR_LEN
            lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(pValue))
            sValue = GetStrFromPtrW(pValue)
  
            Select Case True
                Case InStr(LANG_OK_BUTTON, UCase(sName)) And lRole = ROLE_SYSTEM_PUSHBUTTON
                    pOk = pElement
                Case InStr(LANG_CANCEL_BUTTON, UCase(sName)) And lRole = ROLE_SYSTEM_PUSHBUTTON
                    pCancel = pElement
                Case InStr(LANG_OFFICE_THEME_LABEL, UCase(sName)) And lRole = ROLE_SYSTEM_COMBOBOX
                    pThemeCombo = pElement
            End Select
        
        End If
    
        vFuncOrdinal = 2& 'IUIAutomationElement::Release
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pElement, vTblOffset, vbLong)
    
    Next lIndex
    
    
    vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pThemeCombo, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))

    vFuncOrdinal = 4& 'IID_IUIAutomationLegacyIAccessiblePattern::DoDefaultAction
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pPattern, vTblOffset, vbLong)
 
    'Retrieve ChildCount.
    vFuncOrdinal = 6& ' IUIAutomationElement::FindAll
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pThemeCombo, vTblOffset, vbLong, TreeScope_Subtree, pTrueCond, VarPtr(pChildrenArray))

    vFuncOrdinal = 3& ' IUIAutomationElementArray :get_Length
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pChildrenArray, vTblOffset, vbLong, VarPtr(lChildCount))

    If lChildCount = 0& Then
        GoTo Release_Interfaces
    End If

    For j = 0& To lChildCount - 1&
        
        vFuncOrdinal = 4& ' IUIAutomationElementArray :GetElement
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pChildrenArray, vTblOffset, vbLong, j, VarPtr(pChildElement))

        vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pChildElement, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))

        vFuncOrdinal = 7& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentName
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(pValue))
        sValue = GetStrFromPtrW(pValue)
        
        vFuncOrdinal = 10& 'IID_IUIAutomationLegacyIAccessiblePattern::get_CurrentRole
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pPattern, vTblOffset, vbLong, VarPtr(lRole))
'        lRl = lRole
        
        If lRole = ROLE_SYSTEM_LISTITEM And bRetrievingThemes Then
            ReDim Preserve arThemes(k)
            arThemes(k) = sValue:  k = k + 1&
        End If

        If lRole = ROLE_SYSTEM_LISTITEM And bRetrievingThemes = False Then
    
            If UCase(sValue) = UCase(sTheme) Then
        
                lSelectionFlag = SELFLAG_TAKEFOCUS + SELFLAG_TAKESELECTION
                vFuncOrdinal = 3& 'IUIAutomationLegacyIAccessiblePattern::Select
                vTblOffset = vFuncOrdinal * PTR_LEN
                lRet = vtblStdCall(pPattern, vTblOffset, vbLong, lSelectionFlag)

                vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
                vTblOffset = vFuncOrdinal * PTR_LEN
                lRet = vtblStdCall(pOk, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))

                vFuncOrdinal = 4& 'IID_IUIAutomationLegacyIAccessiblePattern::DoDefaultAction
                vTblOffset = vFuncOrdinal * PTR_LEN
                lRet = vtblStdCall(pPattern, vTblOffset, vbLong)
            
                bFindAndApplyThemesRet = True '< set global flag to indicate success
                GoTo Release_Interfaces
                
            End If
            
        End If

        vFuncOrdinal = 2& 'IUIAutomationLegacyIAccessiblePattern::Release
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pPattern, vTblOffset, vbLong)

        vFuncOrdinal = 2& 'IUIAutomationElement::Release
        vTblOffset = vFuncOrdinal * PTR_LEN
        lRet = vtblStdCall(pChildElement, vTblOffset, vbLong) 'IUIAutomationElementArray ::Release

    Next j
 
    vFuncOrdinal = 14& 'IID_IUIAutomationElement::GetCurrentPatternAs
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pCancel, vTblOffset, vbLong, UIA_LegacyIAccessiblePatternId, VarPtr(iidCuiAuto), VarPtr(pPattern))

    vFuncOrdinal = 4& 'IID_IUIAutomationLegacyIAccessiblePattern::DoDefaultAction
    vTblOffset = vFuncOrdinal * PTR_LEN
    lRet = vtblStdCall(pPattern, vTblOffset, vbLong)
    
Release_Interfaces:
 
    vFuncOrdinal = 2& 'Release
    vTblOffset = vFuncOrdinal * PTR_LEN
    If pAutomation Then
        lRet = vtblStdCall(pChildrenArray, vTblOffset, vbLong) 'IUIAutomationElementArray::Release
        lRet = vtblStdCall(pTrueCond, vTblOffset, vbLong) 'IUIAutomationCondition ::Release
        lRet = vtblStdCall(pElementArray, vTblOffset, vbLong) 'IUIAutomationElementArray ::Release
        lRet = vtblStdCall(pAutomation, vTblOffset, vbLong) 'IUIAutomation::Release
    End If
 
End Sub

Private Function GetAutomationPtr() As LongPtr
    Dim pAutomation As LongPtr
    Const IID_CUIAUTOMATION = "{FF48DBA4-60EF-4201-AA87-54103EEF594E}"
    Const IID_IUIAUTOMATION = "{30CBE57D-D9D0-452A-AB13-7AC5AC4825EE}"
    Const CLSCTX_INPROC_SERVER = &H1, CC_STDCALL = 4&, S_OK = 0&
    Dim iidCuiAuto As GUID, iidIuiAuto As GUID, lRet As Long
    lRet = CLSIDFromString(StrPtr(IID_CUIAUTOMATION), iidCuiAuto)
    Call DispGUID(iidCuiAuto)
    lRet = CLSIDFromString(StrPtr(IID_IUIAUTOMATION), iidIuiAuto)
    Call DispGUID(iidIuiAuto)
    lRet = CoCreateInstance(iidCuiAuto, NULL_PTR, CLSCTX_INPROC_SERVER, iidIuiAuto, pAutomation)
    If lRet = S_OK Then GetAutomationPtr = pAutomation
End Function

Private Function vtblStdCall( _
    ByVal InterfacePointer As LongPtr, _
    ByVal VTableOffset As Long, _
    ByVal FunctionReturnType As Long, _
    ParamArray FunctionParameters() As Variant _
) As Variant

    Const CC_STDCALL = 4&
    Dim vParamPtr() As LongPtr
    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0& To 0&)
        ReDim vParamType(0& To 0&)
    Else
        ReDim vParamPtr(0& To pCount - 1&)
        ReDim vParamType(0& To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc( _
                InterfacePointer, VTableOffset, CC_STDCALL, FunctionReturnType, _
                pCount, vParamType(0&), vParamPtr(0&), vRtn)

    If pIndex = 0& Then
        vtblStdCall = vRtn
    Else
        Call SetLastError(pIndex)
    End If
 
End Function

Private Sub DispGUID(objGuid As GUID)
    Dim lRet As Long, sTmp As String, buf(100&) As Byte
    lRet = StringFromGUID2(objGuid, VarPtr(buf(0&)), UBound(buf) - 1&)
    sTmp = buf
End Sub

Private Function GetStrFromPtrW(ByVal lpString As LongPtr) As String
   Dim lLength As Long, sBuffer As String
   lLength = lstrlen(lpString)
   sBuffer = Space$(lLength)
   Call CopyMemory(ByVal StrPtr(sBuffer), ByVal lpString, lLength * 2&)
   GetStrFromPtrW = sBuffer
End Function

Private Function OfficeThemesExist() As Boolean
    OfficeThemesExist = CBool(Val(Application.Version) >= 12&) ' office>=2007
End Function



2- Code Usage example in the UserForm Module:
VBA Code: 
Option Explicit

Private Sub UserForm_Initialize()
    Dim arThemes() As String
    arThemes = GetAvailableOfficeThemes
    If Not Not arThemes Then
        ComboBox1.List = arThemes
        ComboBox1.ListIndex = 0&
    End If
End Sub

Private Sub CommandButton1_Click()
    If ApplyOfficeTheme(ComboBox1.Value) Then
        'success
    Else
        'Failure
    End If
End Sub
Click to expand...
Two things I noticed:

1. When I cliick on the button, the Office Theme Options, ie Dark Grey, Black, White, etc. temporarily pops up then disappears.

2. Running the code is fine but if I tried stepping into it, it closes Excel when it reaches here:

Code: 
Function ApplyOfficeTheme(ByVal ThemeName As String) As Boolean

    Const WH_CBT = 5&
    Dim lHook As LongPtr
    
    If OfficeThemesExist = False Then GoTo WrongOfficeVersion
   
    sTheme = ThemeName
    bFindAndApplyThemesRet = False
    Call UnhookWindowsHookEx(GetProp(Application.hwnd, "Hook")) '*****************************************************GETTING TO THIS LINE CLOSES EXCEL
    lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, NULL_PTR, GetCurrentThreadId)
    Call SetProp(Application.hwnd, "Hook", lHook)
    Application.CommandBars.ExecuteMso ("ApplicationOptionsDialog")
    Call RemoveProp(Application.hwnd, "Hook")
    sTheme = ""
    ApplyOfficeTheme = bFindAndApplyThemesRet 'FindAndApplyThemes
    Exit Function
    
WrongOfficeVersion:
    MsgBox "Office themes are only availble in editions greater than 2007.", vbCritical, "Error"

End Function

Is it not possible to step into ths code, line by line?
 
Upvote 0
1. When I cliick on the button, the Office Theme Options, ie Dark Grey, Black, White, etc. temporarily pops up then disappears.
Click to expand...
The code immediately closes the Options Dialog and it is hardly noticeable as we can see in the clip preview I posted . I tried preventing the dialog from appearing in response to the HCBT_CREATEWND hook section but it didn't work. I will see if I can do something about it.

2. Running the code is fine but if I tried stepping into it, it closes Excel when it reaches here:
Click to expand...
No. You are never supposed to step into callback routines. But why would you need to? The code is very easy to use both for retrieving the available themes as well as for applying the desired theme.

You don't have to have a userform to make tthis work.

In some module:
VBA Code: 
' For reading the available office themes:
Sub Test1()
    Dim arThemes() As String, i As Long
    arThemes = GetAvailableOfficeThemes
    If Not Not arThemes Then
        For i = LBound(arThemes) To UBound(arThemes)
            Debug.Print arThemes(i)
        Next i
    End If
End Sub


' For Applying an office theme:
Sub Test2()
    ApplyOfficeTheme "White"
End Sub
 
Upvote 0
Jaafar Tribak said:
The code immediately closes the Options Dialog and it is hardly noticeable as we can see in the clip preview I posted . I tried preventing the dialog from appearing in response to the HCBT_CREATEWND hook section but it didn't work. I will see if I can do something about it.


No. You are never supposed to step into callback routines. But why would you need to? The code is very easy to use both for retrieving the available themes as well as for applying the desired theme.

You don't have to have a userform to make tthis work.

In some module:
VBA Code: 
' For reading the available office themes:
Sub Test1()
    Dim arThemes() As String, i As Long
    arThemes = GetAvailableOfficeThemes
    If Not Not arThemes Then
        For i = LBound(arThemes) To UBound(arThemes)
            Debug.Print arThemes(i)
        Next i
    End If
End Sub


' For Applying an office theme:
Sub Test2()
    ApplyOfficeTheme "White"
End Sub
Click to expand...
The popping up is not a problem, I was just curious.

As for stepping into the code, I was interested to see how it worked but wasn't aware you're not meant to step into callback routines.

I'm just happy it's working.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question Question
VBA to change taskbar colour
2
Replies
17
Views
186
Jaafar Tribak
Jaafar Tribak
O
  • Solved
Change Themes colours when I open workbook
Replies
5
Views
157
Domenic
D
frabulator
  • Question Question
Change the Office Theme via VBA with RegEdit
Replies
1
Views
2K
frabulator
frabulator
Z
  • Question Question
Office Themes and VBA Color Sorting/Filtering Issues
Replies
2
Views
953
offthelip
O
Mahantesh_Torgal
  • Question Question
Please help: VBA
Replies
2
Views
78
Mahantesh_Torgal
Mahantesh_Torgal

Forum statistics

Threads
1,223,910
Messages
6,175,318
Members
452,634
Latest member
cpostell

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top