カスタム検索
Office関連

 

トップページ > Office関連 > 配色を変更する(Office 2007 VBA)

 

Sponsored Links

配色を変更する(Office 2007 VBA)

今回はOffice 2007アプリケーションのオプション画面にある「配色」をマクロで変更する方法を紹介します。
※ フック処理を行いますので、実行は自己責任でお願い致します。
※ moug にて、熊谷隆史さんからアドバイスいただき一部コードを修正しました。この場を借りてお礼申し上げます。

 

Option Explicit

Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
Private Declare Function AccessibleObjectFromEvent Lib "oleacc" (ByVal hWnd As Long, ByVal dwObjectID As Long, ByVal dwChildID As Long, ppacc As Office.IAccessible, pvarChild As Variant) As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As Any, ByRef ppvObject As Office.IAccessible) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, lpiid As Any) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function SetWinEventHook Lib "user32" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As Long, ByVal lpfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwflags As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As Long) As Long

Private Const IID_IAccessible As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
Private Const CHILDID_SELF = 0&
Private Const EVENT_SYSTEM_MENUPOPUPSTART = &H6
Private Const HCBT_ACTIVATE = 5&
Private Const OBJID_CLIENT = &HFFFFFFFC
Private Const WH_CBT = 5&
Private Const WINEVENT_OUTOFCONTEXT = &H0

'accRole
Private Const ROLE_SYSTEM_COMBOBOX = &H2E
Private Const ROLE_SYSTEM_LISTITEM = &H22
Private Const ROLE_SYSTEM_PUSHBUTTON = &H2B
Private Const ROLE_SYSTEM_WINDOW = &H9

Private ColorName As String
Private hEventHook As Long
Private hHook As Long

Public Sub ChangeColorScheme(sColorName As String)
'配色変更用
  Select Case sColorName
    Case "青", "銀色", "黒"
      ColorName = sColorName
    Case Else
      MsgBox "引数を確認してください。", vbCritical, "実行時エラー"
      Exit Sub
  End Select

  Call StartHook
  On Error Resume Next
  Call Application.CommandBars.ExecuteMso("ApplicationOptionsDialog") 'オプション画面表示
  If Err.Number <> 0& Then
    Call EndHook
    MsgBox "処理が失敗しました。" & vbCrLf & Err.Description, vbCritical
    Err.Clear
  End If
  On Error GoTo 0
End Sub

Private Sub ChangeComboBox(hWnd As Long)
'コンボボックス変更用
  Dim hWndOpt As Long
  Dim IID(0 To 3) As Long
  Dim accOpt As Office.IAccessible
  Dim accOKBtn As Office.IAccessible
  Dim accCSCbo As Office.IAccessible
  Dim accCSBtn As Office.IAccessible

  hWndOpt = FindWindowEx(hWnd, 0&, "NetUIHWND", vbNullString)
  If hWndOpt = 0& Then Exit Sub
  Call IIDFromString(StrPtr(IID_IAccessible), IID(0))
  If AccessibleObjectFromWindow(hWnd, OBJID_CLIENT, IID(0), accOpt) <> 0& Then Exit Sub
  Set accOKBtn = GetAcc(accOpt, "OK", ROLE_SYSTEM_PUSHBUTTON) 'OKボタン取得

  '"配色:"プルダウン
  Set accCSCbo = GetAcc(accOpt, "配色:", ROLE_SYSTEM_COMBOBOX)
  Set accCSBtn = GetAcc(accCSCbo, "開く", ROLE_SYSTEM_PUSHBUTTON)
  If Not accCSBtn Is Nothing Then
    Call StartEventHook 'イベントフック開始
    accCSBtn.accDoDefaultAction (CHILDID_SELF)
    DoEvents
    Call EndEventHook 'イベントフック終了(念のため)
  End If

  accOKBtn.accDoDefaultAction (CHILDID_SELF) 'OKボタンクリック
End Sub

Private Sub StartHook()
'フック開始
  If hHook <> 0& Then Exit Sub
  hHook = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, GetModuleHandle(vbNullString), GetCurrentThreadId())
  Debug.Print "--- フック開始 --- (" & Hex(hHook) & ")" '確認用
End Sub

Private Sub EndHook()
'フック終了
  If hHook = 0& Then Exit Sub
  Call UnhookWindowsHookEx(hHook)
  hHook = 0&
  Debug.Print "--- フック終了 ---" '確認用
End Sub

Private Function CBTProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'コールバック関数
  Dim sClassName As String
  Dim sClassBuff As String * 255

  If nCode = HCBT_ACTIVATE Then
    If GetClassName(wParam, sClassBuff, Len(sClassBuff)) <> 0& Then
      sClassName = Left$(sClassBuff, InStr(sClassBuff, vbNullChar) - 1&)
      If sClassName = "NUIDialog" Then
        Call ChangeComboBox(wParam)
        Call EndHook 'フック終了
      End If
    End If
  End If

  CBTProc = CallNextHookEx(hHook, nCode, wParam, lParam)
End Function

Private Sub SelColor(myAcc As Office.IAccessible)
'色選択
  Dim accListItem As Office.IAccessible

  Set accListItem = GetAcc(myAcc, ColorName, ROLE_SYSTEM_LISTITEM)
  accListItem.accDoDefaultAction (CHILDID_SELF)
  DoEvents
End Sub

Private Sub StartEventHook()
'イベントフック開始
  If hEventHook <> 0& Then Exit Sub
  hEventHook = SetWinEventHook(EVENT_SYSTEM_MENUPOPUPSTART, EVENT_SYSTEM_MENUPOPUPSTART, 0&, AddressOf WinEventProc, 0&, GetCurrentThreadId(), WINEVENT_OUTOFCONTEXT)
  Debug.Print "--- イベントフック開始 --- (" & Hex(hEventHook) & ")" '確認用
End Sub

Private Sub EndEventHook()
'イベントフック終了
  If hEventHook = 0& Then Exit Sub
  Call UnhookWinEvent(hEventHook)
  hEventHook = 0&
  Debug.Print "--- イベントフック終了 ---" '確認用
End Sub

Private Sub WinEventProc(ByVal hWinEventHook As Long, ByVal levent As Long, ByVal hWnd As Long, ByVal idObject As Long, ByVal idChild As Long, ByVal dwEventThread As Long, ByVal dwmsEventTime As Long)
'コールバック関数
  Dim myAcc As Office.IAccessible
  Dim v As Variant

  If AccessibleObjectFromEvent(hWnd, idObject, idChild, myAcc, v) = 0& Then
    On Error Resume Next
    If (myAcc.accState(CHILDID_SELF) = 0&) And _
       (myAcc.accRole(CHILDID_SELF) = ROLE_SYSTEM_WINDOW) And _
       (myAcc.accParent.accName(CHILDID_SELF) = "") Then
      Call SelColor(myAcc)
      Call EndEventHook 'イベントフック終了
    End If
    On Error GoTo 0
  End If
End Sub

Private Function GetAcc(myAcc As Office.IAccessible, myAccName As String, myAccRole As Long) As Office.IAccessible
'IAccessibleオブジェクト取得用
  Dim ReturnAcc As Office.IAccessible
  Dim ChildAcc As Office.IAccessible
  Dim List() As Variant
  Dim Count As Long
  Dim i As Long

  If (myAcc.accState(CHILDID_SELF) <> 32769) And _
     (myAcc.accName(CHILDID_SELF) = myAccName) And _
     (myAcc.accRole(CHILDID_SELF) = myAccRole) Then
    Set ReturnAcc = myAcc
  Else
    Count = myAcc.accChildCount

    If Count > 0& Then
      ReDim List(Count - 1&)
      If AccessibleChildren(myAcc, 0&, ByVal Count, List(0), Count) = 0& Then
        For i = LBound(List) To UBound(List)
          If TypeOf List(i) Is Office.IAccessible Then
            Set ChildAcc = List(i)
            Set ReturnAcc = GetAcc(ChildAcc, myAccName, myAccRole)
            If Not ReturnAcc Is Nothing Then Exit For
          End If
        Next
      End If
    End If

  End If

  Set GetAcc = ReturnAcc
End Function

上記コードを標準モジュールに貼り付け下記のように色名を引数にして「ChangeColorScheme」を呼び出すことで、配色を変更することができます。

 

Public Sub Sample()
  'Call ChangeColorScheme("青") '青に変更
  'Call ChangeColorScheme("銀色") '銀色に変更
  Call ChangeColorScheme("黒") '黒に変更

  MsgBox "配色を変更しました。", vbInformation
End Sub

※ 上記コードはOfficeのバージョン変更等に伴って、正常に動作しなくなる可能性があります。
※ 上記コードをExcel以外のOfficeアプリケーションで実行する場合は、一部コードを変更する必要があります。

トップページ > Office関連 > 配色を変更する(Office 2007 VBA)