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

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


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

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

広告

テキスト形式のメールを指定文字数で折り返すマクロ

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


Outlook2010を使用しています。
ほぼ1年前の124のコメントで「ある」さんが書かれていますが、私も送信してみないと折り返しの状況がわからないのは大変不便に感じています。
「ある」さんのご要望は送信前のプレビューでしたが、いっそのことVBAで強制的に改行させることはできませんでしょうか?
使い方としては、
1.普通にメールを作成
2.整形したい部分を範囲選択
3.マクロ実行で、その部分を整形(折り返し桁数で改行)
4.必要に応じて修正
5.メールを送信
のような感じです。
高機能な整形は不要で、単純に強制改行させるだけで良いのですが、マクロのご検討をお願いできませんでしょうか?


こちら、選択した範囲ではなくメール本文全体を折り返すということであれば、以下のようなマクロで可能です。一応、半角英数字で構成される単語は途中で改行しないようなロジックを入れたため、ちょっと複雑になっています。

‘ ここをトリプルクリックでマクロ全体を選択できます。
Public Sub WrapLines()
    Const LINE_MAX = 70 ‘ 折り返しの文字数を指定します
    Dim strBody As String
    Dim strNewBody As String
    Dim strLine As String
    Dim c As String
    Dim pCur As Long
    Dim pWB As Long
    Dim iLen As Long
    Dim bWrap As Boolean
    ‘
    strBody = ActiveInspector.CurrentItem.Body
    strBody = Replace(strBody, vbCrLf, vbLf)
    pCur = 1
    pWB = 0
    strNewBody = ""
    strLine = ""
    iLen = 0
    pc = ""
    bWrap = False
    While pCur <= Len(strBody)
        c = Mid(strBody, pCur, 1)
        If c = vbLf Then
            If Not bWrap Then
                strNewBody = strNewBody & strLine & vbLf
            End If
            strLine = ""
            iLen = 0
            pWB = 0
            bWrap = False
        ElseIf Asc(c) < 0 Or &H7F < Asc(c) Then
            iLen = iLen + 2
            If iLen + 1 >= LINE_MAX Then
                strNewBody = strNewBody & strLine & c & vbLf
                strLine = ""
                iLen = 0
                bWrap = True
            Else
                strLine = strLine & c
                bWrap = False
            End If
            pWB = Len(strLine)
        Else
            If c = " " Then
                pWB = Len(strLine) + 1
                bWrap = False
            End If
            iLen = iLen + 1
            If iLen >= LINE_MAX Then
                If pWB > 0 Then
                    strNewBody = strNewBody & Left(strLine, pWB) & vbLf
                    strLine = Mid(strLine, pWB + 1) & c
                    If c = " " Then
                        If Mid(strBody, pCur – 1, 1) <> vbLf And Mid(strBody, pCur + 1, 1) <> " " Then
                            strLine = ""
                        End If
                    End If
                    bWrap = False
                Else
                    strNewBody = strNewBody & strLine & c & vbLf
                    strLine = ""
                    bWrap = True
                End If
                iLen = LenB(StrConv(strLine, vbFromUnicode))
            Else
                strLine = strLine & c
                bWrap = False
            End If
        End If
        pCur = pCur + 1
        Debug.Print iLen, bWrap, strLine
    Wend
    If strLine <> "" Then
        strNewBody = strNewBody & strLine
    End If
    ActiveInspector.CurrentItem.Body = strNewBody
End Sub

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

Outlook の予定表に 2013 年以降の祝日を追加するスクリプト

Outlook では祝日の情報は通常の予定アイテムと同様のものであり、予定表のオプションから国を選んで追加する必要があります。
Outlook 2010 以降では 2013 年の祝日がリリース当初から含まれていますが、Outlook 2007 では修正プログラムの適用が必要であり、Outlook 2003 以前では祝日ファイルが提供されていません。
また、Outlook 2007 に修正プログラムを適用したり、Outlook 2007 以前から Outlook 2010 以降にアップグレードしたような場合、それだけでは予定表の祝日は更新されず、改めてインポートする必要があります。

そのため、以前、Outlook の予定表に 2008 年以降の祝日を追加するスクリプトを作ったのですが、このスクリプトでは 2012 年までの祝日が追加されていました。そろそろ 2013 年以降の祝日を追加するスクリプトも必要になるかと思ったので作ってみました。

スクリプトは以下の通りです。下記のスクリプトを AddHoliday.vbs という名前で保存し、ダブルクリックして実行すると、2013 年以降の祝日が Outlook の既定の予定表に追加されます。

' - ここをトリプル クリックするとすべてのコードが選択できます。
'
Option Explicit
Const olFolderCalendars = 9
Const olAppointmentItem = 1
Const olFree = 0
Dim objOutlook
Dim objSession
Dim objCalendar
Dim colEvents
Dim objHoliday
Dim iYear
' Outlook アプリケーション オブジェクトの取得
Set objOutlook = CreateObject("Outlook.Application")
' Namespace オブジェクトの取得
Set objSession = objOutlook.GetNamespace("MAPI")
' 予定表フォルダの取得
Set objCalendar = objSession.GetDefaultFolder(olFolderCalendars)
Set colEvents = objCalendar.Items
' 予定表から 2013 年以降の祝日のみを取得
Set objHoliday = colEvents.Find("[分類項目] = '祝日' AND [開始日] >= '2012/12/31' AND [場所] = '日本'")
' 2013 年以降の祝日を削除
While Not objHoliday Is Nothing
    objHoliday.Delete
    Set objHoliday = colEvents.FindNext
Wend
'
' 2013 年から 2017 年までの祝日を追加
For iYear = 2013 to 2017
    AddNormalHoliday "天皇誕生日", iYear, 12, 23
    AddNormalHoliday "勤労感謝の日", iYear, 11, 23
    AddNormalHoliday "文化の日", iYear, 11, 3
    AddHappyMonday "体育の日", iYear, 10, 2
    AddHappyMonday "敬老の日", iYear, 9, 3
    AddHappyMonday "海の日", iYear, 7, 3
    AddNormalHoliday "こどもの日", iYear, 5, 5
    AddNormalHoliday "みどりの日", iYear, 5, 4
    AddNormalHoliday "憲法記念日", iYear, 5, 3
    AddNormalHoliday "昭和の日", iYear, 4, 29
    AddNormalHoliday "建国記念の日", iYear, 2, 11
    AddHappyMonday "成人の日", iYear, 1, 2
    AddNormalHoliday "元日", iYear, 1, 1
Next
' 日付が一定でない祝日の追加
AddNormalHoliday "春分の日", 2013, 3, 20
AddNormalHoliday "春分の日", 2014, 3, 21
AddNormalHoliday "春分の日", 2015, 3, 21
AddNormalHoliday "春分の日", 2016, 3, 20
AddNormalHoliday "春分の日", 2017, 3, 20
AddNormalHoliday "秋分の日", 2013, 9, 23
AddNormalHoliday "秋分の日", 2014, 9, 23
AddNormalHoliday "国民の休日", 2015, 9, 22
AddNormalHoliday "秋分の日", 2015, 9, 23
AddNormalHoliday "秋分の日", 2016, 9, 22
AddNormalHoliday "秋分の日", 2017, 9, 23
' - ここに祝日を追加します
' AddNormalHoliday "創立記念日", 2008, 8, 28
'
' 振り替え休日を考慮しない祝日の追加
Sub AddHoliday( sName, dtDay )
    Set objHoliday = objOutlook.CreateItem(olAppointmentItem)
    objHoliday.Subject = sName
    objHoliday.Start = dtDay
    objHoliday.AllDayEvent = True
    objHoliday.Categories = "祝日"
    objHoliday.ReminderSet = False
    objHoliday.BusyStatus = olFree
    objHoliday.Location = "日本"
    objHoliday.Save
    Set objHoliday = Nothing
End Sub
'
' ハッピーマンデーの祝日の追加
Sub AddHappyMonday( sName, iYear, iMonth, iMonday )
    Dim iWk
    Dim iDay
    Dim dtDay
    iWk = Weekday(iYear & "/" & iMonth & "/1" )
    If iWk <= 2 Then
        iWk = iWk + 4
    Else
        iWk = iWk - 3
    End If
    iDay = 7 * iMonday - iWk
    AddHoliday sName, iYear & "/" & iMonth & "/" & iDay & " 00:00 AM"
End Sub
'
' 通常 (振り替え休日あり) の祝日の追加
Sub AddNormalHoliday( sName, iYear, iMonth, iDay )
    Dim iWk
    Dim dtSub
    Dim objHoliday
    AddHoliday sName, iYear & "/" & iMonth & "/" & iDay & " 00:00 AM"
    iWk = Weekday( iYear & "/" & iMonth & "/" & iDay )
    If iWk = 1 Then
        dtSub = CDate(iYear & "/" & iMonth & "/" & iDay)
        Do    ' 振替休日が国民の祝日だったら、翌日に繰り越し
            dtSub = DateAdd("d", 1, dtSub)
            Set objHoliday = colEvents.Find("[分類項目] = '祝日' AND [開始日] >= '" & _
                dtSub & " 00:00 AM' AND [終了日] <= '" & DateAdd("d", dtSub, 1) & _
                "' AND [場所] = '日本'")
        Loop While Not objHoliday Is Nothing
        AddHoliday "振替休日 (" & sName & ")", dtSub & " 00:00 AM"
    End If
End Sub

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

2013/03/09 追記:
Outlook 2003 用の祝日ファイルが下記のリンクより公開されました。
http://support.microsoft.com/kb/2834206/ja

Outlook で HTML ソースの編集を行うマクロ

Outlook Express では HTML メールのソースを編集することができるのですが、Outlook ではその機能がありません。
そこで、Outlook で HTML メールのソースを編集するマクロを作ってみました。コードは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Sub HTMLEdit()
    Dim objShell As Object
    Dim objFso As Object
    Dim strFileName As String
    Dim stmFile As Object
'
    Set objShell = CreateObject("WScript.Shell")
    Set objFso = CreateObject("Scripting.FileSystemObject")
    strFileName = objShell.ExpandEnvironmentStrings("%temp%\") & objFso.GetTempName()
    Set stmFile = objFso.CreateTextFile(strFileName, True)
    stmFile.WriteLine ActiveInspector.CurrentItem.HTMLBody
    stmFile.Close
    objShell.Run "%windir%\notepad " & strFileName, , True
    Set stmFile = objFso.OpenTextFile(strFileName, 1)
    ActiveInspector.CurrentItem.HTMLBody = stmFile.ReadAll
    stmFile.Close
    objFso.DeleteFile strFileName
End Sub

使用方法:

  1. 新規メッセージを作成します。
  2. 上記のマクロを実行します。
  3. メモ帳が起動しますので、HTML ソースを編集して上書き保存します。
  4. メモ帳を閉じると、編集した HTML ソースがメッセージに反映されます。

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

Outlook 2002 以前の個人用フォルダ ファイルおよび個人用アドレス帳のパス名を取得するスクリプト

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


現在、OL2000からOL2007への移行プロジェクトに携わっております。
今回、OL2000に現状紐づいているファイルを取得できるスクリプトを教えて
いただければと思い投稿させていただきました。
貴サイト内にて"Outlook 個人用フォルダ ファイルのパス名を取得するスクリプト"
を拝見しましたが、OL2000環境では正常に動作いたしませんでした。
環境———————————————
OS:Win2000 Sp4
Outlook Ver. : Microsoft Outlook 2000 SR-1 (9.0.0.3821)
————————————————-
実現できれば良いなと思っていること——————
・対象のユーザーでログインし、スクリプトをたたき、現在紐づいている
 PSTファイルのフルパスの取得。
・取得した情報は%userprofile%\デスクトップ\mail_path.txtとして保存
・取得したPSTファイルのフルパスが複数ある場合は、配信先になっている
 PSTファイルに何らかのしるしをつける。
・個人用アドレス帳がある場合はそのフルパスも取得
 ない場合は個人用アドレス帳無しと記載mail_path.txtに記載
————————————————————–
以上になります。


今回は、こちらの質問に回答させていただきます。

Outlook 2002 以前では PST のパス名は以下のレジストリ値に保存されています。

    レジストリ キー: HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\プロファイル名\ランダムな 16 進数
    値の名前: 001e6700
    値の種類: REG_STRING

Outlook 2003 とは異なり、PST のパス名などは Unicode データではなく、通常の文字列 (日本語環境では Shift-JIS) で保存されています。
また、その PST が既定の配信先として設定されているかどうかは、以下のレジストリ値の最初の 1 バイトの 2 ビット目がオンであるかどうかで判別可能です。

    レジストリ キー: HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\プロファイル名\ランダムな 16 進数
    値の名前: 00033009
    値の種類: REG_STRING

これらのレジストリ キーのランダムな 16 進数を取得する方法は、Outlook 2003 と同様です。

さらに、PAB のパス名は以下のレジストリ値に保存されています。

    レジストリ キー: HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\プロファイル名\ランダムな 16 進数
    値の名前: 001e6600
    値の種類: REG_STRING

このレジストリ キーのランダムな 16 進数は以下のレジストリ値から取得可能です。

    レジストリ キー: HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\プロファイル名\9207f3e0a3b11019908b08002b2a56c2
    値の名前: 01023d01
    値の種類: REG_BINARY

以下は、既定の MAPI プロファイルで使用されている PST と PAB のパス名を取得し、%userprofile%\デスクトップ\mail_path.txtとして保存する VBScript です。既定の配信先となっている PST については、ファイル名の後に "[既定の配信先]" という文字列が付与されます。また、PAB がプロファイルに存在しない場合は、最後に「個人用アドレス帳無し」と書き込みます。

' ここをトリプルクリックでマクロ全体を選択できます。
Const HKEY_CURRENT_USER = &H80000001
Const MAPI_PROFILE_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
Const MAPI_SERVICES_KEY = "9207f3e0a3b11019908b08002b2a56c2"
Const PR_STORE_PROVIDERS = "01023d00"
Const PR_AB_PROVIDERS = "01023d01"
Const PR_PST_PATH = "001e6700"
Const PR_PAB_PATH = "001e6600"
Const PR_RESOURCE_FLAGS = "00033009"
Const SERVICE_DEFAULT_STORE = 2
Dim strLogFile
Dim stdRegProv
Dim strDefaultProfile
Dim strProfileKey
Dim strServicesKey
Dim arrServiceUIDs
Dim objFS
Dim objShell
Dim stmText
Dim iCount
Dim i,j
Dim strServiceKey
Dim strPSTPath
Dim strPABPath
Dim arrData
Dim bPABExists
' ログファイルを開く
Set objShell = CreateObject("WScript.Shell")
strLogFile = objShell.ExpandEnvironmentStrings("%userprofile%") & "\デスクトップ\mail_path.txt"
Set objFS = CreateObject("Scripting.FileSystemObject")
Set stmText = objFS.CreateTextFile(strLogFile, True)
' MAPI プロファイルのレジストリを開く
Set stdRegProv = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
stdRegProv.GetStringValue HKEY_CURRENT_USER, MAPI_PROFILE_KEY, "DefaultProfile", strDefaultProfile
strProfileKey = MAPI_PROFILE_KEY & "\" & strDefaultProfile & "\"
strServicesKey = strProfileKey & MAPI_SERVICES_KEY
' PST の取得処理
stdRegProv.GetBinaryValue HKEY_CURRENT_USER, strServicesKey, PR_STORE_PROVIDERS, arrServiceUIDs
iCount = (UBound(arrServiceUIDs)+1)/16
For i=0 To iCount-1
    strServiceKey = ""
    For j=0 To 15
        strServiceKey = strServiceKey & Right("0" & Hex(arrServiceUIDs(i*16+j)), 2)
    Next
    If stdRegProv.GetStringValue(HKEY_CURRENT_USER, strProfileKey & strServiceKey, PR_PST_PATH, strPSTPath) = 0 Then
        stdRegProv.GetBinaryValue HKEY_CURRENT_USER, strProfileKey & strServiceKey, PR_RESOURCE_FLAGS, arrData
        If (arrData(0) And SERVICE_DEFAULT_STORE) = 0 Then
            stmText.WriteLine strPSTPath
        Else
            stmText.WriteLine strPSTPath & vbTab & "[既定の配信先]"
        End If
    End If
Next
' PAB の取得処理
stdRegProv.GetBinaryValue HKEY_CURRENT_USER, strServicesKey, PR_AB_PROVIDERS, arrServiceUIDs
iCount = (UBound(arrServiceUIDs)+1)/16
bPABExists = False
For i=0 To iCount-1
    strServiceKey = ""
    For j=0 To 15
        strServiceKey = strServiceKey & Right("0" & Hex(arrServiceUIDs(i*16+j)), 2)
    Next
    If stdRegProv.GetStringValue(HKEY_CURRENT_USER, strProfileKey & strServiceKey, PR_PAB_PATH, strPABPath) = 0 Then
        stmText.WriteLine strPABPath
        bPABExists =  True
    End If
Next
If Not bPABExists Then
    stmText.WriteLine "個人用アドレス帳無し"
End If
' 後処理
stmText.Close
'
Set stdRegProv = Nothing
Set stmText = Nothing
Set objFS = Nothing
Set objShell = Nothing

Outlook 2002 以前で新着メッセージを処理するマクロを記述する

このブログで紹介しているマクロのうち、新着メッセージについて処理するマクロでは Application オブジェクトの NewMailEx というイベントを使用しています。しかし、これは Outlook 2003 から追加された新しいイベントです。
そのため、Outlook 2002 以前のバージョンでは NewMailEx を使った受信時の処理を行うマクロを登録しても実行されません。
Outlook 2002 以前のバージョンで NewMailEx と同様の処理を実現するマクロを作成しましたので、新着メッセージの処理をするには以下のコードを追加してください。
なお、マクロによっては他にも Outlook 2003 以降で追加された機能を使用している場合もありますので、これを追加しても動作しないことがあるかもしれません。

' ここをトリプルクリックでマクロ全体を選択できます。
Dim WithEvents myInbox As Outlook.Items
'
Private Sub Application_Startup()
    Set myInbox = Session.GetDefaultFolder(olFolderInbox).Items
End Sub
'
Private Sub myInbox_ItemAdd(ByVal Item As Object)
    Application_NewMailEx Item.EntryID
End Sub

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

Outlook の予定表に 2008 年以降の祝日を追加するスクリプト

Outlook 2003 や Outlook 2002 では製品に含まれる祝日データに 2008 年以降の祝日が無く、更新データをダウンロードしてから祝日をインポートする必要があるのですが、これを行うと Outlook 2003 では 2006 年と 2007 年の祝日が重複してしまいます。
また、Outlook 2000 以前ではそもそも更新データがなく、祝日データをユーザーが自分でカスタマイズしてインポートする必要があります。

そこで、Outlook の予定表に祝日を追加するスクリプトを紹介します。
このスクリプトを編集することで独自に祝日を追加することも可能です。
たとえば、2008/8/28 を創立記念日として追加する場合、「’- ここに祝日を追加します」の下に、以下の 1 行を追加します。

AddHoliday "創立記念日", "2008/08/28 00:00 AM"

スクリプトは以下の通りです。下記のスクリプトを AddHoliday.vbs という名前で保存し、ダブルクリックして実行すると、2008 年以降の祝日が Outlook の既定の予定表に追加されます。

' - ここをトリプル クリックするとすべてのコードが選択できます。
'
Option Explicit
Const olFolderCalendars = 9
Const olAppointmentItem = 1
Const olFree = 0
Dim objOutlook
Dim objSession
Dim objCalendar
Dim colEvents
Dim objHoliday
Dim iYear
' Outlook アプリケーション オブジェクトの取得
Set objOutlook = CreateObject("Outlook.Application")
' Namespace オブジェクトの取得
Set objSession = objOutlook.GetNamespace("MAPI")
' 予定表フォルダの取得
Set objCalendar = objSession.GetDefaultFolder(olFolderCalendars)
Set colEvents = objCalendar.Items
' 予定表から 2008 年以降の祝日のみを取得
Set objHoliday = colEvents.Find("[分類項目] = '祝日' AND [開始日] >= '2007/12/31' AND [場所] = '日本'")
' 2008 年以降の祝日を削除
While Not objHoliday Is Nothing
    objHoliday.Delete
    Set objHoliday = colEvents.FindNext
Wend
'
' 2008 年から 2012 年までの祝日を追加
For iYear = 2008 to 2012
    AddNormalHoliday "天皇誕生日", iYear, 12, 23
    AddNormalHoliday "勤労感謝の日", iYear, 11, 23
    AddNormalHoliday "文化の日", iYear, 11, 3
    AddHappyMonday "体育の日", iYear, 10, 2
    AddHappyMonday "敬老の日", iYear, 9, 3
    AddHappyMonday "海の日", iYear, 7, 3
    AddNormalHoliday "こどもの日", iYear, 5, 5
    AddNormalHoliday "みどりの日", iYear, 5, 4
    AddNormalHoliday "憲法記念日", iYear, 5, 3
    AddNormalHoliday "昭和の日", iYear, 4, 29
    AddNormalHoliday "建国記念の日", iYear, 2, 11
    AddHappyMonday "成人の日", iYear, 1, 2
    AddNormalHoliday "元日", iYear, 1, 1
Next
' 日付が一定でない祝日の追加
AddNormalHoliday "春分の日", 2008, 3, 20
AddNormalHoliday "春分の日", 2009, 3, 20
AddNormalHoliday "春分の日", 2010, 3, 21
AddNormalHoliday "春分の日", 2011, 3, 21
AddNormalHoliday "春分の日", 2012, 3, 20
AddNormalHoliday "秋分の日", 2008, 9, 23
AddNormalHoliday "国民の休日", 2009, 9, 22
AddNormalHoliday "秋分の日", 2009, 9, 23
AddNormalHoliday "秋分の日", 2010, 9, 23
AddNormalHoliday "秋分の日", 2011, 9, 23
AddNormalHoliday "秋分の日", 2012, 9, 22
' - ここに祝日を追加します
' AddNormalHoliday "創立記念日", 2008, 8, 28
'
' 振り替え休日を考慮しない祝日の追加
Sub AddHoliday( sName, dtDay )
    Set objHoliday = objOutlook.CreateItem(olAppointmentItem)
    objHoliday.Subject = sName
    objHoliday.Start = dtDay
    objHoliday.AllDayEvent = True
    objHoliday.Categories = "祝日"
    objHoliday.ReminderSet = False
    objHoliday.BusyStatus = olFree
    objHoliday.Location = "日本"
    objHoliday.Save
    Set objHoliday = Nothing
End Sub
'
' ハッピーマンデーの祝日の追加
Sub AddHappyMonday( sName, iYear, iMonth, iMonday )
    Dim iWk
    Dim iDay
    Dim dtDay
    iWk = Weekday(iYear & "/" & iMonth & "/1" )
    If iWk <= 2 Then
        iWk = iWk + 4
    Else
        iWk = iWk - 3
    End If
    iDay = 7 * iMonday - iWk
    AddHoliday sName, iYear & "/" & iMonth & "/" & iDay & " 00:00 AM"
End Sub
'
' 通常 (振り替え休日あり) の祝日の追加
Sub AddNormalHoliday( sName, iYear, iMonth, iDay )
    Dim iWk
    Dim dtSub
    Dim objHoliday
    AddHoliday sName, iYear & "/" & iMonth & "/" & iDay & " 00:00 AM"
    iWk = Weekday( iYear & "/" & iMonth & "/" & iDay )
    If iWk = 1 Then
        dtSub = CDate(iYear & "/" & iMonth & "/" & iDay)
        Do    ' 振替休日が国民の祝日だったら、翌日に繰り越し
            dtSub = DateAdd("d", 1, dtSub)
            Set objHoliday = colEvents.Find("[分類項目] = '祝日' AND [開始日] >= '" & _
                dtSub & " 00:00 AM' AND [終了日] <= '" & DateAdd("d", dtSub, 1) & _
                "' AND [場所] = '日本'")
        Loop While Not objHoliday Is Nothing
        AddHoliday "振替休日 (" & sName & ")", dtSub & " 00:00 AM"
    End If
End Sub