Msdn フォーラムに「Outlook2010のVBAメニューバー追加処理に関して」という質問がありました。

Outlook 2010でマクロを呼び出すためのメニューをリボンに追加したい、というような質問ですが、OutlookがリボンUIに変更されたことで、コマンドバーを利用したマクロが意図通りに動かなくなってしまったようです。

質問者の方は、ApplicationオブジェクトのItemLoadイベントを利用することで、Outlookアイテムが読み込まれた時点でCommandBarsオブジェクトのAddメソッドを使ってメニューを追加する方法を試されているようでしたが、この方法だとメールをプレビュー表示しただけでマクロが実行されてしまいます。

私の方からはInspectorsオブジェクトのNewInspectorイベントを利用する方法を提案しましたが、マクロ上で何らかのエラーが発生してしまうと、Outlookを再起動しなくてはならないため、こちらもあまり使い勝手がよくありません。

「CommandBars の以前のコードの更新」によると、“CommandBarsを使う代わりにリボンのカスタマイズを使うように！”ということが書かれていますが、アドインを使用してIRibbonExtensibilityインターフェイスを実装する必要があるため、WordやExcel、PowerPointとは違って、Outlookの場合はカスタマイズしたリボンを適用することが容易ではありません。

もちろん、Visual StudioやSharpDevelopを使ってCOMアドインを作ってしまえば良いのですが、VBAだけで処理しなくてはならない場合は、何かしら工夫する必要があります。

そこで考えたのが“officeUIファイルを動的にカスタマイズする方法”です。

officeUIファイルは「Office 2010 でカスタマイズしたリボンとクイック アクセス ツール バーを展開する」にある通り、リボンやクイック アクセス ツール バーのカスタマイズ情報が記録されたファイルです。

通常はアプリケーションのオプション画面にある「リボンのユーザー設定」や「クイック アクセス ツール バー」からカスタマイズを行うわけですが、officeUIファイルの実体はXMLファイルなので、動的に読み込んで内容を書き換えることが可能です。

というわけで、早速コードを考えてみました。

※ 下記コードはOffice 2007では動作しません。
※ 下記コードはOutlook 2010で動作確認を行いました。

'ThisOutlookSession
Option Explicit

Private Sub Application_Startup()
  Dim officeUIFolderPath As String
  Dim officeUIFilePath As String
  Dim d As Object
  Dim elmBtn As Object
  Dim elmScs As Object
  Dim elmQat As Object
  Dim elmRbn As Object
  Dim elmCui As Object
  Dim atrMacroNs As Object
  Dim macroNsName As String
  
  'マクロ呼び出し用button要素の属性値
  Const button_idQ As String = "btnExecuteProc"
  Const button_label As String = "マクロ実行"
  Const button_imageMso As String = "HappyFace" 'アイコン指定
  Const button_onAction As String = "Project1.ThisOutlookSession.btnExecuteProc_onAction" '実行するマクロ指定
  
  Const CSIDL_LOCAL_APPDATA = &H1C&
  
  '初期化
  macroNsName = ""
  Set d = CreateObject("Msxml2.DOMDocument")
  d.async = False
  
  'officeUIファイルのパス取得
  officeUIFolderPath = AddPathSeparator(CreateObject("Shell.Application") _
                                        .NameSpace(CSIDL_LOCAL_APPDATA).Self.Path)
  officeUIFolderPath = officeUIFolderPath & "Microsoft\Office\"
  officeUIFilePath = officeUIFolderPath & "olkmailitem.officeUI"
  
  On Error GoTo Err
  With CreateObject("Scripting.FileSystemObject")
    'officeUIファイルがある場合
    If .FileExists(officeUIFilePath) = True Then
      If d.Load(officeUIFilePath) = True Then
        'customUI要素にマクロ呼び出し用名前空間が無ければ追加
        macroNsName = HasMacroNameSpace(d.FirstChild)
        If Len(Trim(macroNsName)) < 1 Then
          macroNsName = "x1"
          Set atrMacroNs = d.createAttribute("xmlns:" & macroNsName)
          atrMacroNs.NodeValue = "http://schemas.microsoft.com/office/2009/07/customui/macro"
          d.FirstChild.Attributes.setNamedItem atrMacroNs
        End If
        
        If d.getElementsByTagName("mso:sharedControls").Length > 0 Then
          Set elmScs = d.getElementsByTagName("mso:sharedControls")(0)
          'sharedControls要素の子要素としてbutton要素が無ければ追加
          If elmScs.getElementsByTagName("mso:button").Length < 1 Then
            Set elmBtn = d.createElement("mso:button")
            elmBtn.setAttribute "idQ", macroNsName & ":" & button_idQ
            elmBtn.setAttribute "label", button_label
            elmBtn.setAttribute "imageMso", button_imageMso
            elmBtn.setAttribute "onAction", button_onAction
            elmScs.appendChild elmBtn
          Else
            If HasMacroButtonElement(elmScs, button_idQ) = False Then
              Set elmBtn = d.createElement("mso:button")
              elmBtn.setAttribute "idQ", macroNsName & ":" & button_idQ
              elmBtn.setAttribute "label", button_label
              elmBtn.setAttribute "imageMso", button_imageMso
              elmBtn.setAttribute "onAction", button_onAction
              elmScs.appendChild elmBtn
            End If
          End If
          'Debug.Print d.XML '確認用
          d.Save officeUIFilePath 'officeUIファイル(XML)保存
        Else: GoTo Err
        End If
      Else: GoTo Err
      End If
    Else
    'officeUIファイルが無い場合
      'button要素
      Set elmBtn = d.createElement("mso:button")
      elmBtn.setAttribute "idQ", "x1:" & button_idQ
      elmBtn.setAttribute "label", button_label
      elmBtn.setAttribute "imageMso", button_imageMso
      elmBtn.setAttribute "onAction", button_onAction
      'sharedControls要素
      Set elmScs = d.createElement("mso:sharedControls")
      elmScs.appendChild elmBtn
      'qat要素
      Set elmQat = d.createElement("mso:qat")
      elmQat.appendChild elmScs
      'ribbon要素
      Set elmRbn = d.createElement("mso:ribbon")
      elmRbn.appendChild elmQat
      'customUI要素
      Set elmCui = d.createElement("mso:customUI")
      elmCui.setAttribute "xmlns:x1", "http://schemas.microsoft.com/office/2009/07/customui/macro"
      elmCui.setAttribute "xmlns:mso", "http://schemas.microsoft.com/office/2009/07/customui"
      elmCui.appendChild elmRbn
      d.appendChild elmCui
      d.Save officeUIFilePath 'officeUIファイル(XML)保存
    End If
  End With
  On Error GoTo 0
  
  Exit Sub
Err:
  MsgBox "処理が失敗しました。", vbExclamation + vbSystemModal
End Sub

Public Sub btnExecuteProc_onAction()
'動的に追加したクイック アクセス ツール バーのボタンから呼び出されるマクロ
  MsgBox "OK", vbInformation + vbSystemModal
End Sub

Private Function HasMacroNameSpace(ByVal elmCui As Object) As String
'マクロ呼び出し用名前空間がある場合はprefixを返す
  Dim ret As String
  Dim n As Object
  
  ret = "" '初期化
  For Each n In elmCui.Attributes
    If n.NodeValue = "http://schemas.microsoft.com/office/2009/07/customui/macro" Then
      ret = n.nodeName
      ret = Replace(ret, "xmlns:", "")
      Exit For
    End If
  Next
  HasMacroNameSpace = ret
End Function

Private Function HasMacroButtonElement(ByVal elmScs As Object, _
                                       ByVal idQValue As String) As Boolean
'マクロ呼び出し用button要素の有無を判断
  Dim ret As Boolean
  Dim n As Object
  
  ret = False '初期化
  For Each n In elmScs.getElementsByTagName("mso:button")
    If InStr(n.Attributes.getNamedItem("idQ").NodeValue, idQValue) Then
      ret = True
      Exit For
    End If
  Next
  HasMacroButtonElement = ret
End Function

Private Function AddPathSeparator(ByVal s As String) As String
  If Right(s, 1) <> ChrW(&H5C) Then s = s & ChrW(&H5C)
  AddPathSeparator = s
End Function

上記マクロは、ApplicationオブジェクトのStartupイベントを使って、

1. olkmailitem.officeUIファイル(「Office 2010 でカスタマイズしたリボンとクイック アクセス ツール バーを展開する」参照)の有無を確認し、ファイルが無ければ動的に作成する。
2. olkmailitem.officeUIファイルが存在する場合は、マクロを呼び出すための要素(button)の有無を確認する。
3. マクロを呼び出すための要素が存在しない場合には、動的に要素を追加する。

というような処理をOutlook起動時に行います。

従って上記マクロが上手く動作した場合は、メール作成画面のクイック アクセス ツール バーに、マクロを呼び出すためのボタンが自動的に追加されます。

動作確認した限りでは、一応意図通りに動作するようです。
ただ、officeUIファイルの動的な書き換えというのは、上記コードの通り煩雑な処理になりますので、この方法もあまり効率の良い方法とは言えないでしょう。

やはり、Outlookのアドインを作成できる環境があるのであれば、「CommandBars の以前のコードの更新」にある通り、アドインを作成して対応するのが良いだろうと思います。