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イベントを使って、
- olkmailitem.officeUIファイル(「Office 2010 でカスタマイズしたリボンとクイック アクセス ツール バーを展開する」参照)の有無を確認し、ファイルが無ければ動的に作成する。
- olkmailitem.officeUIファイルが存在する場合は、マクロを呼び出すための要素(button)の有無を確認する。
- マクロを呼び出すための要素が存在しない場合には、動的に要素を追加する。
というような処理をOutlook起動時に行います。
従って上記マクロが上手く動作した場合は、メール作成画面のクイック アクセス ツール バーに、マクロを呼び出すためのボタンが自動的に追加されます。
動作確認した限りでは、一応意図通りに動作するようです。
ただ、officeUIファイルの動的な書き換えというのは、上記コードの通り煩雑な処理になりますので、この方法もあまり効率の良い方法とは言えないでしょう。
やはり、Outlookのアドインを作成できる環境があるのであれば、「CommandBars の以前のコードの更新」にある通り、アドインを作成して対応するのが良いだろうと思います。
この記事へのコメントはありません。