アイテム一覧の右クリックメニューにマクロを追加する方法

コメントで以下のようなご要望をいただきました。


Outlook2010にサイトのマクロをカスタマイズして使っています。
大変快適な環境になっております。

メール画面で右クリック時のショートカットメニューにマクロを割り振る方法をアドバイス頂けますか。
例えば
右クリック
メール移動
>分類(仕事)+仕事メールフォルダー
>分類(プライベート)+プライベートメールフォルダー

などマクロでメールアイテムを分類し、別のプロファイル(仕事.pst)にコピーするというものです。
メール移動のマクロは既に作成していますが、リボンに割り振っているためその都度マウスでリボンまで移動し選択するので、ショートカットに割り振れれば作業効率が良くなるのではと思っております。

あわせて、組み込んだマクロにアイコンをつけたいと思っております。
ExcelだとFaceIdがあり、アイコンを割り振ることができますが、Outlookでは可能なのでしょうか。


Outlook 2010 でアイテムの右クリックにより表示されるコンテキスト メニューをカスタマイズするには、Application の ItemContextMenuDisplay イベントを使用します。
このイベントはコンテキスト メニューが表示されるタイミングで呼び出されるもので、引数として渡された CommandBar オブジェクトにボタンを追加すると、それがコンテキスト メニューに表示される動作となります。
なお、この CommandBar オブジェクトは Office 製品に共通のオブジェクトであるため、Excel と同様に FaceId を使ってアイコンを設定することが可能です。

マクロは以下の通りになります。ちなみに、単に分類項目を割り当ててメッセージを移動するというだけであれば、クイック操作でも設定可能です。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemContextMenuDisplay(ByVal oCommandBar As Office.CommandBar, ByVal oSelection As Selection)
    If oSelection.Count > 0 Then
        Dim objPopup As CommandBarPopup
        Dim objButton1 As CommandBarButton
        Dim objButton2 As CommandBarButton
        ' 親メニュー
        Set objPopup = oCommandBar.Controls.Add(msoControlPopup, , , , True)
        objPopup.Caption = "メール移動"
        ' サブメニュー 1
        Set objButton1 = objPopup.Controls.Add(msoControlButton, , , , True)
        With objButton1
            .Style = msoButtonIconAndCaption
            .Caption = "仕事"
            .FaceId = 1100
            .OnAction = "Project1.ThisOutlookSession.CategorizeAsWork"
        End With
        ' サブメニュー 2
        Set objButton2 = objPopup.Controls.Add(msoControlButton, , , , True)
        With objButton2
            .Style = msoButtonIconAndCaption
            .Caption = "プライベート"
            .FaceId = 225
            .OnAction = "Project1.ThisOutlookSession.CategorizeAsPrivate"
        End With
    End If
End Sub
' サブメニュー 1 で呼び出されるマクロ
Private Sub CategorizeAsWork()
    Dim fldDest As Folder
    ' 移動先は受信トレイの下の「仕事」フォルダー
    Set fldDest = Session.GetDefaultFolder(olFolderInbox).Folders("仕事")
    CategorizeMessage "仕事", fldDest
End Sub
' サブメニュー 2 で呼び出されるマクロ
Private Sub CategorizeAsPrivate()
    Dim fldDest As Folder
    ' 移動先は受信トレイの下の「プライベート」フォルダー
    Set fldDest = Session.GetDefaultFolder(olFolderInbox).Folders("プライベート")
    CategorizeMessage "プライベート", fldDest
End Sub
' メッセージに分類項目をつけて移動するマクロ
Private Sub CategorizeMessage(strCategory As String, fldDest As Folder)
    Dim objMsg As MailItem
    ' 選択されているメッセージすべてに対して処理を行う
    For Each objMsg In ActiveExplorer.Selection
        ' 分類項目を設定
        objMsg.Categories = strCategory
        ' メッセージを移動
        objMsg.Move fldDest
    Next
End Sub

マクロの登録方法やメニューへの追加について

Outlook で送信できないメールアドレスを自動的に修正して送信可能とするマクロ

Outlook で送信できないメールアドレス」のコメント欄にて以下のようなご要望をいただきました。


..や.@が含まれるdocomoとezwebあてのアドレスを自動で” “でくくるようなVBAは組めないものでしょうか。


確かに、送信時に自動的に ”” でくくってしまえば送信はできるようになりますね。
マクロは以下のようなものになります。このマクロはメールの送信時に自動的に実行されるので、手動で実行させる必要はありません。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    FixMailAddress Item
End Sub
' 不正なアドレスに "" をつけるサブ プロシージャ
Private Sub FixMailAddress(ByVal objMail As MailItem)
    Dim i As Integer
    Dim strNewAddress As String
    Dim objRec As Recipient
    For i = objMail.Recipients.Count To 1 Step -1
        With objMail.Recipients.Item(i)
            ' 受信者のアドレスに連続するピリオドや @ 直前のピリオドがある場合
            If InStr(.Address, "..") > 0 Or InStr(.Address, ".@") > 0 Then
                ' @ より前を "" でくくる
                strNewAddress = """" & Left(.Address, InStr(.Address, "@") - 1) & """" _
                    & Mid(.Address, InStr(.Address, "@"))
                ' 変更後のアドレスで受信者を追加
                Set objRec = objMail.Recipients.Add("""" & .Name & """ <" & strNewAddress & ">")
                ' To か Cc か Bcc かを指定
                objRec.Type = .Type
                objRec.Resolve
                ' 元の受信者は削除
                .Delete
            End If
        End With
    Next
End Sub

マクロの登録方法やメニューへの追加について

特定のフォルダーのサブフォルダーを直下に移動するマクロ

コメントにて以下のようなご要望をいただきました。


連絡先
連絡先\仕事用\仕事999\仕事888
連絡先\仕事用\友人A\友人B\友人C\友人D

上記のような階層構造になってしまった場合、すべてのフォルダを1アクション(バッチ/スクリプト等)で連絡先直下に移動することは可能でしょうか。


以下のようなマクロで実現可能です。なお、連絡先に限定するのは汎用性に欠けるので、現在指定されているフォルダーのサブフォルダーすべてを対象とするという動作にしています。そのため、連絡先の直下に移動するという場合は、連絡先を選択した状態でマクロを実行してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub MoveToTop()
    Dim fldTop As Folder
    Dim fldSub As Folder
    ' 現在選択されているフォルダーを最上位フォルダーとする
    Set fldTop = ActiveExplorer.CurrentFolder
    ' 最上位フォルダーのサブ フォルダーをチェック
    For Each fldSub In fldTop.Folders
        MoveToTopRecursive fldSub, fldTop
    Next
End Sub
' 再帰的に処理するサブ プロシージャ
Private Sub MoveToTopRecursive(fldCurrent As Folder, fldTop As Folder)
    Dim i As Integer
    ' サブフォルダーを再帰的に既定の連絡先に移動
    For i = fldCurrent.Folders.Count To 1 Step -1
        MoveToTopRecursive fldCurrent.Folders(i), fldTop
    Next
    ' 処理中のフォルダーの親が最上位フォルダーでない場合のみ
    If fldCurrent.Parent.EntryID <> fldTop.EntryID Then
        ' フォルダー自身を既定の連絡先に移動
        fldCurrent.MoveTo fldTop
    End If
End Sub

マクロの登録方法やメニューへの追加について

連絡先をエクスポート・インポートするスクリプト

コメントにて以下のご要望をいただきました。


学校のパソコン教室でPCが40台あって、それぞれがoutlook2013を使ってメールを送受信します。アドレス帳を40台のPCで、共有したいと思っています。サンプルのアドレス帳の一覧データをCSVファイルでエクスポートして、LAN上の指定された共有フォルダに保存しておいて、他のPCは、ワンタッチでマクロでそのアドレス帳のデータを自動的にインポートするマクロを作りたいと思っています。なにせ、マクロは全くの初心者なので、どうすれば良いのか教えていただけますでしょうか?よろしくお願いします。


データを CSV にエクスポートするということなのですが、アドレス帳のデータを CSV にしようとするとフィールドの数が多くちょっと面倒です。
ほかのアプリケーションから取り込むのではなく Outlook で取り込むということであれば、PST ファイルのほうが手間もかからず損失するデータもないので良いでしょう。

また、マクロの場合すべての PC でマクロを記述する必要があるのですが、これもまた面倒なのでスクリプトを使うほうが良いと思います。

以下は、連絡先のすべてのアイテムを C:\temp\export.pst の「連絡先」というフォルダーにエクスポートするスクリプトです。
このコードをメモ帳などで拡張子を .vbs として保存し、ベースとなるアドレスデータを持つ PC で実行します。(.vbs のファイルはダブルクリックで実行できます。)
ファイル名を変更したい場合は "PST_FILE=" として設定しているファイル名を変更してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Const PST_FILE = "c:\temp\export.pst"
Const olFolderContacts = 10
On Error Resume Next
Dim olkApp 'As Outlook.Application
Dim objPST 'As Store
Dim fldRoot 'As Folder
Dim fldSrc 'As Folder
Dim fldDst 'As Folder
Dim conSrc 'As ContactItem
Dim conDst 'As ContactItem
'
Set olkApp = CreateObject("Outlook.Application")
With olkApp.Session
    Set fldSrc = .GetDefaultFolder(olFolderContacts)
    .AddStore PST_FILE
    For Each objPST In .Stores
        If objPST.FilePath = PST_FILE Then
            Exit For
        End If
    Next
    Set fldRoot = objPST.GetRootFolder()
    Set fldDst = fldRoot.Folders.Add("連絡先", olFolderContacts)
    If Err.Number <> 0 Then
        Set fldDst = fldRoot.Folders.Item("連絡先")
    End If
    For Each conSrc In fldSrc.Items
        Set conDst = conSrc.Copy()
        conDst.Move fldDst
    Next
    .RemoveStore fldRoot
End With

次に、下記のコードも同様に拡張子を .vbs として保存し、今度はインポートする PC で実行してください。
なお、PST ファイルはあらかじめ PC の "C:\temp\export.pst" としてコピーしておく必要があります。
ファイル名をネットワークパスにすることも可能ですが、ネットワークパスで PST を使う場合には破損の危険がありますので、PST ファイルはバックアップしておいてください。

' ここをトリプルクリックでマクロ全体を選択できます。
Const PST_FILE = "c:\temp\export.pst"
Const olFolderContacts = 10
On Error Resume Next
Dim olkApp 'As Outlook.Application
Dim objPST 'As Store
Dim fldRoot 'As Folder
Dim fldSrc 'As Folder
Dim fldDst 'As Folder
Dim conSrc 'As ContactItem
Dim conDst 'As ContactItem
'
Set olkApp = CreateObject("Outlook.Application")
With olkApp.Session
    Set fldDst = .GetDefaultFolder(olFolderContacts)
    .AddStore PST_FILE
    For Each objPST In .Stores
        If objPST.FilePath = PST_FILE Then
            Exit For
        End If
    Next
    Set fldRoot = objPST.GetRootFolder()
    Set fldSrc = fldRoot.Folders.Item("連絡先")
    For Each conSrc In fldSrc.Items
        Set conDst = conSrc.Copy()
        conDst.Move fldDst
    Next
    .RemoveStore fldRoot
End With

マクロの登録方法やメニューへの追加について

複数の連絡先フォルダーから連絡先を検索し、メールの先頭に受信者の名前を追加するマクロ

コメントにて以下のようなご要望をいただきました。


あて先に指定したアドレスの名前を本文に追加するマクロを使用させて頂いてます。
大変便利な機能で、活用させて頂いております。

現在、複数の連絡先フォルダを使っておりますが、AddHeaderでは対応していない思います。
対応して頂けると助かります。

連絡先(会社)にあるアドレスからの返信時には
事業所名
名前 + 敬称
連絡先(顧客)にあるアドレスからの返信時には
会社名
名前 + 役職

というようになればさらに便利になると思います。

よろしくお願いします。


既定の連絡先フォルダーの直下に複数のフォルダーがあると想定した場合のマクロは以下のようになります。AddHeader2 を実行してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub AddHeader2()
    Dim objMail As MailItem
    Dim objContact As ContactItem
    Dim objContacts As Folder
    Dim i As Integer
'
    Set objMail = Application.ActiveInspector.CurrentItem
    Set objContacts = Application.Session.GetDefaultFolder(olFolderContacts)
    For i = objMail.Recipients.Count To 1 Step -1
        With objMail.Recipients.Item(i)
            If .Type = olTo Then
                Set objContact = FindContactByAddressInAFolder(.Address, objContacts)
                If Not objContact Is Nothing Then
                    objMail.Body = objContact.LastFirstAndSuffix & vbCrLf & objMail.Body
                Else
                    Set objContact = FindContactByAddressInAFolder(.Address, objContacts.Folders("連絡先(会社)"))
                    If Not objContact Is Nothing Then
                        objMail.Body = objContact.Department & vbCrLf & "  " & objContact.LastFirstSpaceOnly & " " & objContact.JobTitle & vbCrLf & objMail.Body
                    Else
                        Set objContact = FindContactByAddressInAFolder(.Address, objContacts.Folders("連絡先(顧客)"))
                        If Not objContact Is Nothing Then
                            objMail.Body = objContact.CompanyName & vbCrLf & "  " & objContact.LastFirstAndSuffix & vbCrLf & objMail.Body
                        End If
                    End If
                End If
            End If
        End With
    Next
End Sub
'
Private Function FindContactByAddressInAFolder(strAddress As String, objContacts)
    Dim objContact As ContactItem
    '
    Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress _
        & "' or [Email2Address] = '" & strAddress _
        & "' or [Email3Address] = '" & strAddress & "'")
    Set FindContactByAddressInAFolder = objContact
End Function

マクロの登録方法やメニューへの追加について

送信前に機種依存文字をチェックするマクロ

コメントにて以下のようなご要望をいただきました。


Outlook2010でメール送信をする際、機種依存文字(半角カナ含む)が含まれているか
チェックするマクロをご教授頂きたくお願いいたします。
もし機種依存文字が含まれていれば、コメントボックス等で対象文字が分かるような形
だと助かります。
よろしくお願いいたします。


ご要望のマクロは下記のようなものになります。なお、半角カタカナについては Outlook では送信時に自動的に全角文字となるため、チェックする必要はないかもしれません。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    CheckNonJIS Item, Cancel
End Sub
'
Private Sub CheckNonJIS(ByVal objItem As Object, bCancel As Boolean)
    Dim strBody As String
    Dim c As String
    Dim ic As Integer
    Dim i As Integer
    Dim strError As String
    Dim strNonJIS As String
    Dim strUnicode As String
    strBody = objItem.Body
    '
    For i = 1 To Len(strBody)
        c = Mid(strBody, i, 1)
        ic = Asc(c)
        If ic < 0 And (ic < &H8140 Or (&H8740 <= ic And ic < &H889F) Or &HEB40 <= ic) Then
            strNonJIS = strNonJIS & c
        ElseIf ic >= &HA1 Then
            strNonJIS = strNonJIS & c
        ElseIf ic = &H3F And c <> "?" Then
            strUnicode = strUnicode & c
        End If
    Next
    If strNonJIS <> "" Or strUnicode <> "" Then
        strError = "以下の文字が含まれているため送信を中止します。" & vbCrLf
        If strNonJIS <> "" Then
            strError = strError & "機種依存文字:" & strNonJIS & vbCrLf
        End If
        If strUnicode <> "" Then
            strError = strError & "Unicode 文字" & vbCrLf
        End If
        MsgBox strError, vbCritical, "送信文字チェック"
        bCancel = True
    End If
End Sub

マクロの登録方法やメニューへの追加について

アイテムに対してマクロを実行する際の記述方法

Outlook でアイテムに対して何らかのマクロを動作させるという場合、主に以下のような方法があります。

  1. ダブルクリックして開いたアイテムに対して実行する
  2. アイテム一覧で選択したアイテムに対して実行する
  3. メッセージを受信したタイミングで実行する
  4. 自動仕分けで実行する

このブログのマクロも上記のいずれかのパターンで動作させていますが、状況によってはほかのタイミングで動作させたいということもあるでしょう。

今回は、下記の単に件名を表示するだけのマクロを例に、上記のそれぞれのタイミングで実行するための記述方法についてまとめてみました。

Private Sub DisplaySubject( objItem As MailItem )
    MsgBox objItem.Subject
End Sub

1. ダブルクリックして開いたアイテムに対して実行する

アイテムをダブルクリックして開くと、そのアイテムは ActiveInspector と呼ばれるオブジェクトの CurrentItem から参照できます。
そのため、以下のような記述でダブルクリックして開いたアイテムについて上記のマクロが実行できます。

Public Sub DisplaySubjectActive()
    DisplaySubject ActiveInspector.CurrentItem
End Sub

2. アイテム一覧で選択したアイテムに対して実行する

アイテム一覧で選択したアイテムは、ActiveExplorer の Selection により参照できます。アイテムは複数選択できるため、Selection(1) というように番号を付けて選択したアイテムを取得します。
以下は、最初に選択したアイテムで上記のマクロを実行するマクロです。

Public Sub DisplaySubjectSelected()
    DisplaySubject ActiveExplorer.Selection(1)
End Sub

3. 上記の二つを自動選択して実行する

現在アクティブなウィンドウを自動的に識別して実行してくれたら便利かもしれません。
以下は、そのようなマクロの記述方法です。

Public Sub DisplaySubjectAuto()
    If TypeName(ActiveWindow) = "Explorer" Then
        DisplaySubject ActiveExplorer.Selection(1)
    Else
        DisplaySubject ActiveInspector.CurrentItem
    End If
End Sub

4. メッセージを受信したタイミングで実行する

このブログのマクロではよく使われますが、受信したタイミングでマクロを実行するには Application_NewMailEx イベントを使用します。

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objItem
    Set objItem = Session.GetItemFromID(EntryIDCollection)
    If TypeName(objItem) = "MailItem" Then
        DisplaySubject objItem
    End If
End Sub

5. 自動仕分けで実行する

自動仕分けで実行するには Public として定義し、引数は必ず ByRef で MailItem 型の変数を一つだけ指定する必要があります。

Public Sub DisplaySubjectByRule( ByRef objItem As MailItem)
    DisplaySubject objItem
End Sub

 

このブログやほかのサイトなどで見つけたマクロで、実行タイミングを変えたいという場合には、上記の記述を参考にしてみてください。