予定表で表示されているすべての日に同じ時間で予定を作成するマクロ

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


マクロ作成でいつも参考にさせていただいております。

https://outlooklab.wordpress.com/2019/02/09/選択した予定表フォルダーの特定の日に時間固定/

のマクロで、個人の定期的な予定をワンクリックで入れられるようになって便利なのですが、
例えば、予定表の左側(ナビゲーションウィンドウ)のカレンダーの日付をCtrl+左クリックで複数の日付を選択した上でマクロを実行して一括で同じ予定追加・・・
というのが実現できれば非常に便利だなと思い、実現させたいのですが、
複数選択したひとつひとつの日付をどのように取得するのか?(あるいは選択した日付の範囲内の1日1日をどう取得するのか?)という壁にぶつかっています。
お忙しいところ恐縮なのですが、よろしくお願い申し上げます。


予定表で複数の日を表示してるときに、表示されている日付のリストを取得するには、ActiveExplorer の CurrentView プロパティで取得できる CalendarView オブジェクトの DisplayedDates プロパティを使用します。
このプロパティに配列として格納されている日付に予定アイテムを作成することで、ご要望は実現可能です。
マクロは以下の通りです。

Public Sub AddAppointmentToSelectedDate()
     ' 作成する予定の件名を指定
     Const APPT_SUBJECT = "会議"
     ' 作成する予定の開始時刻
     Const APPT_START_TIME = "9:00"
     ' 作成する予定の終了時刻
     Const APPT_END_TIME = "12:00"
     Dim fldCalendar As Folder
     Dim apptItem As AppointmentItem
     Dim arrSelDate As Variant
     Dim strSelDate As Variant
     ' 現在選択しているフォルダーを取得
     Set fldCalendar = ActiveExplorer.CurrentFolder
     ' フォルダーの種類が予定表だった場合だけ追加
     If fldCalendar.DefaultItemType = olAppointmentItem Then
         ' 表示されている日付を配列で取得
         arrSelDate = ActiveExplorer.CurrentView.DisplayedDates
         For Each strSelDate In arrSelDate
             ' 選択されたフォルダーにアイテムを追加
             Set apptItem = fldCalendar.Items.Add()
             ' 件名、開始日時、終了日時を指定
             apptItem.Subject = APPT_SUBJECT
             apptItem.Start = strSelDate & " " & APPT_START_TIME
             apptItem.End = strSelDate & " " & APPT_END_TIME
             ' アイテムを保存
             apptItem.Save
         Next
     End If
End Sub

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

アイテムをダブルクリックした時と複数開いた状態で選択した時にマクロを実行する方法

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


いつも参考にさせていただいております。
受信トレイにあるメールを Inspector で取り扱いたいのですが
・受信トレイ内のあるメールをダブルクリックしたとき
・すでにダブルクリックで開いてあるメールが複数あり、そのなかから1つのメールを選択したとき
の2種類で他のマクロを呼び出したいのですが、ご紹介いただけますか?


まず、受信トレイ内のメールをダブルクリックで開いた際には、Inspectors オブジェクトの NewInspector イベントが実行されますので、このイベントでマクロを記述すれば処理が実行できます。
問題はすでに開いているメールを選択した場合の処理です。
Inspector の Activate イベントを使用すれば処理できるのですが、VBA ではイベントを配列に対して設定できないため、複数 Inspector オブジェクトがある場合に ThisOutlookSession 内では一つの Inspector しかイベント処理ができないということになるのです。
この制限を回避するためには、Inspector のイベントを処理するためのクラス モジュールを定義し、そのオブジェクトを処理するためのクラス モジュールを別途定義する必要があります。

手順としては、まず Visual Basic Editor を起動し、[Project1] を右クリックして [挿入]-[クラス モジュール] をクリックします。
すると、Class1 というクラス モジュールが作成されるので、(オブジェクト名) を “ExInspector” に変更し、以下のコードをクラス モジュールのコードとして記載します。

Private WithEvents myInspector As Inspector
Private myParent As ExInspectors
Private myID As String
'
Private Sub Class_Initialize()
     myID = Timer & "-" & Rnd()
End Sub
'
Public Sub Init(objInspector As Inspector, objInspectors As ExInspectors)
     Set myInspector = objInspector
     Set myParent = objInspectors
     objInspectors.ColInspectors.Add Me, myID
     ' ここにダブルクリックで開かれた際の処理を追加
     MsgBox "New Inspector"
End Sub
' ウィンドウが選択された際の処理
Private Sub myInspector_Activate()
     If myParent.IsActiveInspector(myInspector) Then
     Else
     ' ここに複数ウィンドウで選択された際の処理を追加
         MsgBox "Activated"
     End If
End Sub
' ウィンドウが閉じられた際の処理
Private Sub myInspector_Close()
     myParent.ColInspectors.Remove myID
     Set myParent = Nothing
End Sub

次に、再び [Project1] を右クリックして [挿入]-[クラス モジュール] をクリックします。
そして、今度は (オブジェクト名) を “ExInspectors” に変更し、以下のコードをクラス モジュールのコードとして記載します。


Private WithEvents myInspectors As Inspectors
Private myActiveInspector As Inspector
Public ColInspectors As Collection
'
Private Sub Class_Initialize()
     Set myInspectors = Application.Inspectors
     Set ColInspectors = New Collection
End Sub
' アイテムを開いた時の処理
Private Sub myInspectors_NewInspector(ByVal Inspector As Inspector)
     Dim inspWrap As New ExInspector
     Set myActiveInspector = Inspector
     inspWrap.Init Inspector, Me
End Sub
' プロパティ ダイアログなどを開いた後で選択された際の処理が再実行されないようにするための関数
Public Function IsActiveInspector(ByVal objInspector As Inspector)
     If myActiveInspector Is objInspector Then
         IsActiveInspector = True
     Else
         Set myActiveInspector = objInspector
         IsActiveInspector = False
     End If
End Function

最後に、ThisOutlookSession に以下のコードを記載して保存し、Outlook を起動します。

Private myInspectors As ExInspectors
'
Private Sub Application_Startup()
     Set myInspectors = New ExInspectors
End Sub

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

14 周年

2007 年にこのブログをはじめて、14 周年になりました。

昨年は約 82 万アクセスとなり、残念ながら 100 万を超えることはできませんでした。
「Outlook マクロ」や「Outlook VBA マクロ」での検索結果の順位が年々低下していることが原因かもしれません。

それでも数多くの方々に読んでいただき、コメントでご要望をお寄せいただくことで何とか毎週更新ができております。

本当にありがとうございます。

これからも、Outlook を活用してもらうべく、様々なマクロや Tips を紹介してまいりますので、よろしくお願いいたします。

サブフォルダーのメールで受信時刻から30分経過しているものがあったら通知メールを送信するマクロ

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


初めまして VBA初心者です。
OutLook2016で以下の条件のマクロを作成したいと考えています。

・サブフォルダ「未対応」にメールがあるか確認
 ・ない場合→何もしない
 ・ある場合→受信時間が現在時間から30分以上経過しているか確認
  ・30分未満→何もしない
  ・30分以上経過→通知メールを作成して送信

ご回答よろしくお願いします。


まず、受信トレイのサブフォルダーである「未対応」というフォルダーを取得するには、Session オブジェクトの GetDefaultFolder メソッドで olFolderInbox を指定して受信トレイを取得し、そのオブジェクトの Folders でフォルダー名を指定します。
次に、取得したフォルダーのメールについては、フォルダーの Items コレクションから For Each で一つずつ取得できるので、そのアイテムの ReceivedTime プロパティと Now 関数で取得した現在の時刻を DateDiff 関数で比較し、30 分以上経過していたら通知メールを送信することで実現可能です。
通知メールについては元のメールの転送から作成するようにしてみました。

Public Sub CheckUnhandled()
     ' 通知メールの送信先
     Const NOTIFY_TO = "notify@example.com"
     ' 通知メールの件名
     Const NOTIFY_SUBJECT = "未対応のメールがあります"
     ' 通知メールの本文
     Const NOTIFY_BODY = "以下のメールは未対応です。対応をお願いします。"
     Dim fldInbox As Folder
     Dim fldTarget As Folder
     Dim mailCheck As MailItem
     Dim mailNotify As MailItem
     ' 受信トレイを取得
     Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
     ' サブフォルダーの「未対応」を取得
     Set fldTarget = fldInbox.Folders("未対応")
     ' サブフォルダーのメールをすべて確認
     For Each mailCheck In fldTarget.Items
         ' 受信時刻より 30 分以上経過していた場合
         If DateDiff("n", mailCheck.ReceivedTime, Now) >= 30 Then
             ' 通知メールは転送メールから作成
             Set mailNotify = mailCheck.Forward
             ' 通知メールの送信先を指定
             mailNotify.To = NOTIFY_TO
             ' 通知メールの件名を指定
             mailNotify.Subject = NOTIFY_SUBJECT
             ' 通知メールの本文を先頭に追加
             mailNotify.Body = NOTIFY_BODY & mailNotify.Body
             ' 通知メールを送信
             mailNotify.Send
         End If
     Next
End Sub

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

選択したメールの差出人のアドレスを既存のルールの「差出人のアドレスに特定の文字列が含まれる場合」という条件に追加するマクロ

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


はじめまして。OutlookでのVBAに挑戦しています。
既に自動仕分けルールで作成された、「差出人のアドレスに***が含まれていたら削除する」というルールに対して、メールが来たらボタン一つで受信したメールアドレスを上記の「***」の一覧に追加したいと思っています。
差出人を設定するマクロはサイト内の記事で確認できたのですが、「***が含まれていたら」という所のリストに追加する作業がマクロ化できずに悩んでいます。
ご教授頂きたく宜しくお願い致します。


「差出人のアドレスに特定の文字列が含まれる場合」という条件は、Rule オブジェクトの Conditions.SenderAddress プロパティで取得できる AddressRuleCondition オブジェクトの Address プロパティに格納されています。
このプロパティは文字列配列となっているので、この配列にメールの差出人アドレスを追加することでご要望は実現できます。
マクロは以下のようになります。
追加したいルールが複数ある場合は、AddSenderRuleForSample をコピーし、RULE_NAME を変更して使用してください。

' ルールに条件を追加するマクロ
Public Sub AddSenderRuleForSample()
     Const RULE_NAME = "Sample"
     AddSenderAddressToRuleSelected RULE_NAME
End Sub
' 指定された名前のルールに条件を追加するサブ プロシージャ
Private Sub AddSenderAddressToRuleSelected(strRuleName As String)
     ' 表示中のアイテムを取得してメインの処理を実行
     If TypeName(ActiveWindow) = "Inspector" Then
         AddSenderAddressToRule strRuleName, ActiveInspector.CurrentItem
     Else
         AddSenderAddressToRule strRuleName, ActiveExplorer.Selection(1)
     End If
End Sub
' アイテムをもとにルールに条件を追加するサブ プロシージャ
Private Sub AddSenderAddressToRule(strRuleName As String, objMsg As MailItem)
     Dim colRules As Rules
     Dim oneRule As Rule
     Dim condSender As AddressRuleCondition
     Dim arrAddress() As String
     Dim iNewRule As Integer
     ' 既定のアカウントの自動仕訳ルールを取得
     Set colRules = Session.Accounts.Item(1).DeliveryStore.GetRules()
     ' 指定された名前のルールを検索
     For Each oneRule In colRules
         ' 名前が一致したら
         If oneRule.Name = strRuleName Then
             ' 差出人のアドレスに含まれる文字列の条件を取得
             Set condSender = oneRule.Conditions.SenderAddress
             ' 既に設定されている文字列の配列を取得
             arrAddress = condSender.Address
             ' 配列を拡張
             iNewRule = UBound(arrAddress) + 1
             ReDim Preserve arrAddress(iNewRule)
             ' 配列に差出人のアドレスを追加
             arrAddress(iNewRule) = objMsg.SenderEmailAddress
             ' 追加した文字列を条件に設定
             condSender.Address = arrAddress
             ' ルールを保存
             colRules.Save
             Exit Sub
         End If
     Next
End Sub

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

表示中のフォルダーに含まれるアイテムの埋め込み画像を除いた添付ファイルをすべて保存するマクロ

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


VBA初心者です。
特定のサブフォルダにあるメールの添付ファイルを、指定のフォルダに保存したいのですが
メール本文の埋め込み画像も一緒に保存されてしまって困っています。
「受信したメールの埋め込み画像を除いた添付ファイルを自動保存するマクロ」を参考にしているのですが
メール受信時にではなく、既に受信フォルダにあるものに対しての書き替えがうまくいきません。
本文埋め込み画像以外の添付ファイルを保存するマクロをご教授いただけませんでしょうか。

やりたいこと
サブフォルダに入っているメールの、本文の埋め込み画像以外の添付ファイルを指定フォルダへ保存

よろしくお願いします。


ご要望の動作は以前公開した「表示中のフォルダーに含まれるアイテムの添付ファイルをすべて保存するマクロ」と「受信したメールの埋め込み画像を除いた添付ファイルを自動保存するマクロ」を組み合わせることで実現できます。
組み合わせたマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub SaveAttachmentsInCurrentFolder()
     Dim objItem As Object ' MailItem
     For Each objItem In ActiveExplorer.CurrentFolder.items
         SaveAttachmentsInOneItem objItem
     Next
End Sub
'
Private Sub SaveAttachmentsInOneItem(objItem As Object)
     Const SAVE_PATH = "C:\attachments\"
     Dim objFSO As Object ' FileSystemObject
     Dim objAttach As Attachment
     Dim strFileName As String
     Dim c As Integer
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     '
     ' ここで条件指定
     ' If Not objItem.Subject Like "*Report*" Then Exit Sub
     '
     For Each objAttach In objItem.Attachments
         If Not IsAttachEmbedded(objAttach) Then
             With objAttach
                 strFileName = SAVE_PATH & objAttach.FileName
                 c = 2
                 While objFSO.FileExists(strFileName)
                     strFileName = SAVE_PATH & Left(.FileName, InStrRev(.FileName, ".") - 1) _
                         & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                     c = c + 1
                 Wend
                 .SaveAsFile strFileName
             End With
         End If
     Next
     '
     Set objFSO = Nothing
End Sub
' 添付ファイルが埋め込み画像かどうかをチェックする関数
Private Function IsAttachEmbedded( objAttach As Attachment )
      On Error Resume Next
      Const PR_ATTACH_FLAGS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x37140003"
      Const PR_ATTACH_CONTENT_ID = "http:" & "//schemas.microsoft.com/mapi/proptag/0x3712001E"
      Dim iAttFlags As Integer
      Dim strAttCID As String
      ' 既定は通常の添付ファイル
      IsAttachEmbedded = False
      iAttFlags = 0
      iAttFlags = objAttach.PropertyAccessor.GetProperty(PR_ATTACH_FLAGS)
      If iAttFlags = 0 Then
          ' フラグが 0 またはプロパティが存在しなければ通常の添付ファイル
      Else ' フラグが 0 以外なら埋め込み画像
          IsAttachEmbedded = True
      End If
      strAttCID = ""
      strAttCID = objAttach.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)
      If strAttCID = "" Then
          ' Content ID がない、またはプロパティが存在しなければ通常の添付ファイル
      Else ' Content ID があれば埋め込み画像
          IsAttachEmbedded = True
      End If
      ' OLE オブジェクトなら埋め込み画像
      If objAttach.Type = olOLE Then
          IsAttachEmbedded = True
      End If
End Function

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

Outlook 2016/2013/2010 のセキュリティ修正プログラム 2020 年 12 月分がリリース

12/8 に Outlook 2016、Outlook 2013 および Outlook 2010 のセキュリティ修正プログラムがリリースされました。 以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

Outlook 2016 用のセキュリティ更新プログラムについて: 2020 年12月8日
1 件のセキュリティ修正と 4 件のセキュリティ以外の修正が行われています。

Word 2016 の修正

December 1, 2020, update for Word 2016 (KB4486756)
1 件の Outlook に関する通常の修正が行われています。

Office 2013

Outlook 2013 の修正

Outlook 2013 用のセキュリティ更新プログラムについて: 2020 年12月8日
1 件のセキュリティ修正が行われています。

Office 2010

Outlook 2010 の修正

Outlook 2010 用のセキュリティ更新プログラムについて: 2020 年12月8日
1 件のセキュリティ修正が行われています。

表示中のメールとその添付ファイルを件名のフォルダーに保存するマクロ

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


はじめまして。
OutLook2016 / Windows10の環境でExchangeメールボックスサーバーで利用しています。
「表示中のメールの添付ファイルを件名のフォルダーに保存するマクロ」に関連して、「表示中のメールの添付ファイル及びmsgファイルを件名のフォルダーに保存するマクロ」はどのようにしたら作成できますでしょうか?たったひと手間だと思うのですが、初心者過ぎてどうしたらよいのか困っています…。アドバイスいただけませんでしょうか。また、複数のメールを選択して同様の作業を行えるようにはできますでしょうか?

また、「表示中のメールの添付ファイルを件名のフォルダーに保存するマクロ」を利用しようとしてみたのですが、「アイテムを開けませんでした」や「strEntryIDの変数が設定されていません」と出てしまいます。何か私のマクロの登録方法が間違っているのでしょうか。もし可能でしたら、その辺もアドバイスいただけたらと思います。


表示中のメールの添付ファイルを件名のフォルダーに保存するマクロでは strEntryID という変数は使用していないのですが、受信したメールに添付されたメッセージの添付ファイルも含めて自動保存するマクロあたりも参考にされたということでしょうか?
基本的には表示中のメールの添付ファイルを件名のフォルダーに保存するマクロにメッセージ自体を保存する記述を追加するだけでよいと思いますが、複数のメールを選択する場合のことを考慮して保存処理をサブプロシージャ化してみました。
マクロは以下のようになります。


Private Sub SaveMsgAndAttachmentsInSubjectFolder()
    ' 表示中のアイテムを取得
    If TypeName(ActiveWindow) = "Inspector" Then
        SaveOneMsgAndAttachments ActiveInspector.CurrentItem
    Else
    ’アイテム一覧で選択されたメール全てに対して実行
        Dim objMsg As Variant
        For Each objMsg In ActiveExplorer.Selection
            SaveOneMsgAndAttachments objMsg
        Next
    End If
End Sub
' 一つのメールを保存するサブプロシージャ
Private Sub SaveOneMsgAndAttachments(objMsg As Variant)
     Const MAX_FOLDER_PATH = 130
     Const MAX_PATH = 260
     Const ROOT_PATH = "c:\attachments\"
     Dim strSaveRoot As String
     Dim strSaveFolder As String
     Dim objFSO As Object ' FileSystemObject
     Dim objAttach As Attachment
     '
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     ' 件名から保存するフォルダーのパスを生成
     strSaveFolder = ROOT_PATH & ReplaceSpecialChar(objMsg.Subject)
     strSaveFolder = Left(strSaveFolder, MAX_FOLDER_PATH)
     ' フォルダーが存在しなければ作成
     If Not objFSO.FolderExists(strSaveFolder) Then
         objFSO.CreateFolder strSaveFolder
     End If
     '
     objMsg.SaveAs MakeUniqueFileName(strSaveFolder, "message.msg"), olMSGUnicode
     ' 添付ファイルがなければ終了
     If objMsg.Attachments.Count = 0 Then
         Exit Sub
     End If
     For Each objAttach In objMsg.Attachments
         With objAttach
             .SaveAsFile MakeUniqueFileName(strSaveFolder, .FileName)
         End With
     Next
     Set objMsg = Nothing
     Set objFSO = Nothing
End Sub
' 件名から特殊文字を取り除く関数
Private Function ReplaceSpecialChar(strSubject As String) As String
      ReplaceSpecialChar = ""
      For i = 1 To Len(strSubject)
          ch = Mid(strSubject, i, 1)
          If InStr("\/:*?""|", ch) > 0 Then
              ch = "_"
          End If
          ReplaceSpecialChar = ReplaceSpecialChar & ch
      Next
End Function
' 重複しないファイル名を生成する関数
Private Function MakeUniqueFileName(strPath As String, strFileName As String)
     Dim strFileBase As String
     Dim strExt As String
     Dim iExt As Integer
     Dim c As Integer
     '
     iExt = InStrRev(strFileName, ".")
     If iExt > 0 Then
         strFileBase = Left(strFileName, iExt - 1)
         strExt = Mid(strFileName, iExt)
     Else
         strFileBase = strFileName
         strExt = ".dat"
         strFileName = strFileName & strExt
     End If
     '
     c = 1
     While Dir(strPath & "\" & strFileName) <> ""
         strFileName = strFileBase & "-" & c & strExt
         c = c + 1
     Wend
     MakeUniqueFileName = strPath & "\" & strFileName
End Functio
n

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

2021 年の海の日、山の日およびスポーツの日を移動するスクリプトと 2021 年以降の祝日を追加するスクリプト

11 月 27 日に 2020 年の海の日、山の日およびスポーツの日が東京オリンピックに合わせて移動されるという法律が可決、成立しました。

今後、この法律に基づいて更新された Outlook の祝日ファイルも更新プログラムとして提供されることになると思いますが、すでに延長サポート フェーズに入っている Outlook 2016 や Outlook 2013、先日サポートを終了した Outlook 2010 には提供されない可能性があります。
また、Outlook 2019 や Microsoft 365 Apps for Enterprise の Outlook でも、更新プログラムを適用すれば変更されるというわけではなく、いったん祝日を削除して改めて追加するという作業が必要になります。

そのようなわけで、祝日を移動するスクリプトを作ってみました。
以下のテキストをメモ帳などのテキストエディタに保存し、拡張子を vbs として保存してダブルクリックで実行すると、祝日が移動します。

Option Explicit
Const olFolderCalendar = 9
Const olAppointmentItem = 1
Const olFree = 0
Dim olkApp
Dim fldCal
Dim apptHol
'
Set olkApp = CreateObject("Outlook.Application")
Set fldCal = olkApp.Session.GetDefaultFolder(olFolderCalendar)
'
MoveHoliday fldCal, "海の日", "7/19", "7/22"
MoveHoliday fldCal, "山の日", "8/11", "8/8"
MoveHoliday fldCal, "スポーツの日", "10/11", "7/23"
MoveHoliday fldCal, "体育の日", "10/11", "7/23"
'
Set apptHol = olkApp.CreateItem(olAppointmentItem)
With apptHol
     .Subject = "振替休日 (山の日)"
     .Start = "2021/8/9 0:00"
     .AllDayEvent = True
     .Categories = "祝日"
     .ReminderSet = False
     .BusyStatus = olFree
     .Location = "日本"
     .Save
End With
'
Sub MoveHoliday(fldCal, strName, strStart, strNewStart)
     Set apptHol = fldCal.Items.Find("[件名]='" & strName & _
         "' And [開始日]='2021/" & strStart & " 00:00'")
     If Not apptHol Is Nothing Then
         apptHol.Start = CDate("2021/" & strNewStart)
         apptHol.Save
     End If
End Sub

なお、2021 年以降の祝日もスクリプトで追加したいというような要望もあるかと思い、2021 年から 2026 年までの祝日を追加するスクリプトも作成しました。

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
' 予定表から 2021 年以降の祝日のみを取得
Set objHoliday = colEvents.Find("[分類項目] = '祝日' AND [開始日] >= '2020/12/31' AND [場所] = '日本'")
' 2021 年以降の祝日を削除
While Not objHoliday Is Nothing
     objHoliday.Delete
     Set objHoliday = colEvents.FindNext
Wend
'
' 2021 年から 2026 年までの祝日を追加
For iYear = 2021 to 2026
     AddNormalHoliday "勤労感謝の日", iYear, 11, 23
     AddNormalHoliday "文化の日", iYear, 11, 3
     AddHappyMonday "敬老の日", iYear, 9, 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
     AddNormalHoliday "天皇誕生日", iYear, 2, 23
     If iYear > 2021 Then
         AddHappyMonday "スポーツの日", iYear, 10, 2
         AddNormalHoliday "山の日", iYear, 8, 11
         AddHappyMonday "海の日", iYear, 7, 3
     End If
Next
' 日付が一定でない祝日の追加
AddNormalHoliday "春分の日", 2019, 3, 21
AddNormalHoliday "春分の日", 2020, 3, 20
AddNormalHoliday "春分の日", 2021, 3, 20
AddNormalHoliday "春分の日", 2022, 3, 21
AddNormalHoliday "春分の日", 2023, 3, 21
AddNormalHoliday "春分の日", 2024, 3, 20
AddNormalHoliday "春分の日", 2025, 3, 20
AddNormalHoliday "春分の日", 2026, 3, 20
AddNormalHoliday "秋分の日", 2019, 9, 23
AddNormalHoliday "秋分の日", 2020, 9, 22
AddNormalHoliday "秋分の日", 2021, 9, 23
AddNormalHoliday "秋分の日", 2022, 9, 23
AddNormalHoliday "秋分の日", 2023, 9, 23
AddNormalHoliday "秋分の日", 2024, 9, 22
AddNormalHoliday "秋分の日", 2025, 9, 23
AddNormalHoliday "秋分の日", 2026, 9, 23
' 敬老の日と秋分の日に挟まれるため
AddNormalHoliday "国民の休日", 2026, 9, 22
' 2020 年の祝日移動のための特別処理
AddNormalHoliday "海の日", 2021, 7, 22
AddNormalHoliday "山の日", 2021, 8, 8
AddNormalHoliday "スポーツの日", 2021, 7, 23
'
' 振り替え休日を考慮しない祝日の追加
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

PST への移動ルールを修復するマクロ

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


はじめまして。
OutlookのVBAを検索していて、こちらにたどり着きました。

複数のPCでpstファイルを共有したいと思い、pstファイルをUSBデバイスにコピーして運用しています。USBデバイスからpstをコピーしOutlookを起動した際、仕分けルールが手動実行でないと動作しないため、ルールを一度削除後オプションでインポートしています。この動作をVBA実行したいのですが、可能なものなのでしょうか?


Outlook の仕分けルールで移動先のフォルダーを指定した場合、内部的にはフォルダーのエントリー ID が設定されています。
そのため、例えば移動先のフォルダーが受信トレイのサブフォルダーだった場合に、そのフォルダーをメールボックスのルートなどに移動しても、ルールを変更する必要がないというメリットがあります。
ただ、エントリー ID はメールボックスや PST という単位で固有のものなので、PST 間で移動したり、別の PST を同じファイルパスで上書きしたような場合に無効となってルールがエラーとなります。

仕分けルールのインポート処理を VBA で実行することはできませんが、すでにあるルールについてフォルダーを設定しなおすことは可能です。
以下のようなマクロの FixPSTRules を実行すると、既存のルールについて移動先のフォルダーがエラーとなっていても、指定した PST ファイルのフォルダーに移動するよう変更します。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub FixPSTRules()
     ' ルールの名前、PST のパス、PST 内での移動先フォルダーのパスの順に指定
     ModifyRuleMovingToPST "テスト", "c:\temp\test.pst", "test"
     ' 移動先フォルダーがサブフォルダーの場合は \ で区切ってパスを指定
     ModifyRuleMovingToPST "テスト2", "c:\temp\test.pst", "test\test2"
End Sub
'
Private Sub ModifyRuleMovingToPST(strName As String, strPSTPath As String, strFolder As String)
     Dim objStore As Store
     Dim objRules As Rules
     Dim objRule As Rule
     Dim actMove As MoveOrCopyRuleAction
     Dim fldToMove As Folder
     ' 既定の受信トレイからルールを取得
     Set objStore = Session.GetDefaultFolder(olFolderInbox).Store
     Set objRules = objStore.GetRules()
     ' 引数で指定された名前のルールを検索
     For Each objRule In objRules
         ' ルールが見つかった
         If objRule.Name = strName Then
             ' フォルダーに移動するアクションを取得
             Set actMove = objRule.Actions.MoveToFolder
             ' 移動先となるフォルダーを取得
             Set fldToMove = GetPSTFolder(strPSTPath, strFolder)
             ' 取得したフォルダーを移動先に設定
             actMove.Folder = fldToMove
             Exit For
         End If
     Next
     ' 変更したルールを保存
     objRules.Save
End Sub
'
Private Function GetPSTFolder(strPSTPath As String, strFolder As String) As Folder
     Dim storePST As Store
     Dim arrFolders As Variant
     Dim varFolder As Variant
     Dim fldRoot As Folder
     Dim fldSub As Folder
     ' 指定された PST を念のため追加
     Session.AddStore strPSTPath
     ' PST のストアを検索
     For Each storePST In Session.Stores
         If LCase(storePST.FilePath) = LCase(strPSTPath) Then
             Exit For
         End If
     Next
     ' PST のルートフォルダーを取得
     Set fldRoot = storePST.GetRootFolder
     ' PST のパスを \ で分割
     arrFolders = Split(strFolder, "\")
     On Error Resume Next
     ' フォルダー階層を取得または作成
     For Each varFolder In arrFolders
         Set fldSub = Nothing
         Set fldSub = fldRoot.Folders(varFolder)
         If fldSub Is Nothing Then
             Set fldSub = fldRoot.Folders.Add(varFolder)
         End If
         Set fldRoot = fldSub
     Next
     ' 取得したフォルダーを返す
     Set GetPSTFolder = fldRoot
End Function

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