特定の文字列を含む予定の数日前にメールを自動送信するスクリプト

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


お世話になっております。outlookについて色々調べているうちにこちらにたどり着きました。以下のようなマクロを作成することは難しいでしょうか??何卒ご検討よろしくお願いいたします。
OUTLOOK2016を使用しております。

【やりたいこと】
  現在会社で休暇予定をOUTLOOKのスケジュールに反映したあと、休暇の数日前にメールで関係者宛に休暇連絡をしておりますが、メール発信部分を自動化したいと考えております。

【具体的なマクロの機能】
スケジュールの件名に特定の文字列(例えば「休暇」)を含んだ予定を反映すると、該当スケジュールの5日前に指定した宛先(予め指定しておいたメーリングリスト)にメールを自動発信する


予定を反映した際にその 5 日前にメールを送信するように設定するとなると、メールの遅延送信でスケジュールするという方法が考えられます。
しかし、遅延送信を行う場合は Outlook を起動し続けていなければならず、予定の変更や削除にも対応できません。

そこで、このご要望について以下のように置き換えてみました。

スクリプトを実行した日の 5 日後に特定の件名を含む予定があった場合に、その予定の情報を指定した宛先に送信する。

メールの自動発信についてはタスク スケジューラーによりスクリプトを定期的に実行することで実現できます。
このスクリプトで 5 日後に特定の件名を含む予定を検索し、見つかったらその件名や日付をメールで送信します。
スクリプトは以下のようになります。

' ここをトリプルクリックでスクリプト全体を選択できます。

' 検索するキーワード
Const KEYWORD = "休暇"
' n 日前の設定
Const DATE_BEFORE = 5
' 通知メールの送信先
Const NOTIFY_TO = "notify@example.com"
' 通知メールの件名
Const NOTIFY_SUBJECT = "休暇予定連絡"
' 通知メールの本文
Const NOTIFY_BODY = "以下の日程で休暇をいただきます。"
' Outlook の定数設定
Const olFolderCalendar = 9
Const olMailItem = 0
'
Dim appOlk 'As Outlook.Application
Dim fldCalendar 'As Folder
Dim colItems 'As Items
Dim dtStart 'As Date
Dim dtEnd 'As Date
Dim apptHol 'As AppointmentItem
Dim strBody 'As String
' Outlook の Application オブジェクトを取得
Set appOlk = CreateObject("Outlook.Application")
' 既定の予定表フォルダーを取得
Set fldCalendar = appOlk.Session.GetDefaultFolder(olFolderCalendar)
' 予定表のアイテム一覧を取得
Set colItems = fldCalendar.Items
' 予定アイテムを開始日でソート
colItems.Sort "[開始日]"
' 繰り返しのアイテムを展開
colItems.IncludeRecurrences = True
' n 日後の定義
dtStart = CDate(FormatDateTime(DateAdd("d", DATE_BEFORE, Now), vbShortDate))
dtEnd = CDate(FormatDateTime(DateAdd("d", DATE_BEFORE + 1, Now), vbShortDate))
' n 日後を含む予定を検索
Set apptHol = colItems.Find("[開始日] < '" & dtEnd & "' and [終了日] > '" & dtStart & "'")
strBody = ""
' 検索されるアイテムがなくなるまで繰り返す
While Not apptHol Is Nothing
     With apptHol
         ' 条件が一致する予定かどうかの確認
         If .Start < dtEnd And .End > dtStart And InStr(.Subject, KEYWORD) > 0 Then
             ' 予定の件名と開始日を本文に追記
             strBody = strBody & .Subject & vbTab & .Start
             If .Start < DateAdd("d", -1, .End) Then
                 ' 2 日以上にまたがる場合は終了日も追記
                 strBody = strBody & "-" & DateAdd("d", -1, .End)
             End If
             ' 改行を追記
             strBody = strBody & vbCrLf
         End If
     End With
     ' 次のアイテムを検索
     Set apptHol = colItems.FindNext
Wend
' 予定が見つかっていたら通知メール作成
If strBody <> "" Then
     Dim msgNotify 'As MailItem
     ' メールアイテムを作成
     Set msgNotify = appOlk.CreateItem(olMailItem)
     With msgNotify
         ' 宛先、件名、本文を設定し、送信
         .To = NOTIFY_TO
         .Subject = NOTIFY_SUBJECT
         .Body = NOTIFY_BODY & vbCrLf & strBody
         .Send
     End With
End If

広告

2019 年以降の祝日の追加、変更を行うスクリプト

12 月 14 日に「天皇の即位の日及び即位礼正殿の儀の行われる日を休日とする法律」が公布されました。

今後、この法律に基づいて更新された Outlook の祝日ファイルも更新プログラムとして提供されることになると思いますが、すでに延長サポート フェーズに入っている Outlook 2013 や Outlook 2010 には提供されない可能性があります。
また、Outlook 2016 でも、更新プログラムを適用すれば変更されるというわけではなく、いったん祝日を削除して改めて追加するという作業が必要になります。
さらに、2020 年にはオリンピックに伴う祝日の移動や、「体育の日」から「スポーツの日」への変更、天皇誕生日の変更などもあるので、2019 年から 2016  年までの祝日を追加するスクリプトを作ってみました。
なお、法律の条文などを見ても、新しい祝日の正式な呼称がわからなかったため、5/1 を「即位の日」、10/22 を「即位礼正殿の儀の日」としています。

' ここをトリプル クリックするとすべてのコードが選択できます。
'
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
' 予定表から 2019 年以降の祝日のみを取得
Set objHoliday = colEvents.Find("[分類項目] = '祝日' AND [開始日] >= '2018/12/31' AND [場所] = '日本'")
' 2019 年以降の祝日を削除
While Not objHoliday Is Nothing
     objHoliday.Delete
     Set objHoliday = colEvents.FindNext
Wend
'
' 2019 年から 2026 年までの祝日を追加
For iYear = 2019 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
     ' 2019 年の新天皇即位に伴う祝日
     If iYear = 2019 Then
         AddNormalHoliday "国民の休日", iYear, 4, 30
         AddNormalHoliday "即位の日", iYear, 5, 1
         AddNormalHoliday "国民の休日", iYear, 5, 2
         AddNormalHoliday "即位礼正殿の儀の日", iYear, 10, 22
     End If
     ' 2020 以降は天皇誕生日が 2/23 に
     If iYear >= 2020 Then
         AddNormalHoliday "天皇誕生日", iYear, 2, 23
     End If
     ' 2021 以降は正常
     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 "海の日", 2019, 7, 15
AddNormalHoliday "山の日", 2019, 8, 11
AddNormalHoliday "山の日 (振替休日)", 2019, 8, 12
AddNormalHoliday "体育の日", 2019, 10, 14
AddNormalHoliday "海の日", 2020, 7, 23
AddNormalHoliday "山の日", 2020, 8, 10
AddNormalHoliday "スポーツの日", 2020, 7, 24
'
' 振り替え休日を考慮しない祝日の追加
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

他人の予定表を直接開くスクリプト

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


いつも参照させていただいております。

Outlookの起動オプションを使用して、他人の予定表を直接開く方法を教えてください。

Outlook.exe /select outlook:calendar では自分の予定を開くことはできるのですが、他人の予定表を開く方法がわかりません。

よろしくお願いいたします。


残念ながら、Outlook の起動オプションには他人の予定表を直接開くというものはありません。
おそらくはデスクトップなどにバッチファイルを置いて、それをダブルクリックして他人の予定表を開くというようなものを想定されていると思うのですが、スクリプトにより実現することができます。
下記のようなスクリプトを、例えば OpenOtherFolder.vbs というような名前で保存し、デスクトップにはそのスクリプトへのショートカットを作成します。
その際に、スクリプトのファイル名の後にスペースを空けて開きたいユーザーのメールアドレスを指定します。
例えば、c:\users\admin\desktop\OpenOtherFolder.vbs にスクリプトがあり、test@example.com というアドレスのユーザーの予定表を開きたい場合、ショートカット のリンク先として c:\users\admin\desktop\OpenOtherFolder.vbs test@example.com と指定します。
なお、このスクリプトで開く予定表には参照者以上の権限が必要になります。

' ここをトリプルクリックでスクリプト全体を選択できます。

Const olFolderCalendar = 9
If WScript.Arguments.Count > 0 Then
     Dim strAddress 'As String
     Dim olkApp 'As Outlook.Application
     Dim nsSess 'As Namespace
     Dim recOther 'As Recipient
     Dim fldOther 'As Folder
     ' スクリプトの引数からアドレスを取得
     strAddress = WScript.Arguments.Item(0)
     ' Outlook.Application オブジェクトを取得
     Set olkApp = CreateObject("Outlook.Application")
     Set nsSess = olkApp.Session
     ' アドレスから Recipient オブジェクトを作成
     Set recOther = nsSess.CreateRecipient(strAddress)
     recOther.Resolve
     ' 他のユーザーの予定表を取得し、開く
     Set fldOther = nsSess.GetSharedDefaultFolder(recOther, olFolderCalendar)
     fldOther.Display
End If

連絡先フォルダーのユーザーの予定表を一括で追加するスクリプト

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


【使用環境】
OSバージョン:Windows7 SP1 & Windows10
  Outlookバージョン:Outlook2013
サーバ:Exchange Online

はじめまして。
いつも参考になる多数の記事ありがとうございます。

現在定期的に当サイト記事「連絡先をエクスポート・インポートするスクリプト」を使用し、社内アドレス帳を一括インポートしています。
  又、そのアドレス帳から予定表グループ機能を使用し、予定表の共有を行っていますが、
  社内アドレス帳の更新した際に、予定表グループ接続が無効になってしまいます。(レ点をつけれない)
  原因は、社内アドレスの中身を一度一括削除した上で、一括インポートしているからです。
  解決策として、「新しい予定表グループで作成」で既定のアドレス帳に予定表グループを作成するスクリプトを作成頂けませんか。


スクリプトで他のユーザーの予定表を追加するには、その予定表に参照者以上の権限が必要となります。
連絡先にあるユーザーの予定表に参照者以上の権限がある前提でスクリプトを作成しました。

なお、連絡先に連絡先グループが存在した場合、そのグループの名前で予定表グループを作成し、メンバーの予定表をそのグループに追加する処理も実装しています。

' ここをトリプルクリックでスクリプト全体を選択できます。

' 予定表グループの名前設定
Const GROUP_NAME = "連絡先"
' Outlook の設定値
Const olFolderContacts = 10
Const olModuleCalendar = 1
Const olFolderCalendar = 9
'
Dim olkApp 'As Application
Dim nsSession 'As NameSpace
Dim navGroup 'As NavigationGroup
Dim fldContacts 'As Folder
Dim objItem 'As Object
' Outlook の呼び出し
Set olkApp = CreateObject("Outlook.Application")
Set nsSession = olkApp.Session
' 既定の連絡先フォルダーを取得
Set fldContacts = nsSession.GetDefaultFolder(olFolderContacts)
' 予定表グループを作成
Set navGroup = GetNavigationGroup(GROUP_NAME)
' 連絡先フォルダーのすべてのアイテムについて処理
For Each objItem In fldContacts.Items
     If TypeName(objItem) = "ContactItem" Then
         ' 連絡先アイテムならアイテムのメールアドレスを指定して追加
         AddRecipientToNavigation objItem.Email1Address, navGroup
     ElseIf TypeName(objItem) = "DistListItem" Then
         ' 連絡先グループ アイテムならメンバーを展開して追加
         AddDistListToNavigation objItem
     End If
Next
' 連絡先グループのメンバーを展開して追加するルーチン
Private Sub AddDistListToNavigation(dlItem)
     On Error Resume Next
     Dim navGroup 'As NavigationGroup
     Dim i 'As Integer
     Dim recOther 'As Recipient
     Dim fldCalendar 'As Folder
     ' 連絡先グループの名前で予定表グループを作成
     Set navGroup = GetNavigationGroup(dlItem.DLName)
     ' メンバーを展開して予定表グループに追加
     For i = 1 To dlItem.MemberCount
         Set recOther = dlItem.GetMember(i)
         AddRecipientToNavigation recOther.Address, navGroup
     Next
End Sub
' メールアドレスにより予定表グループに追加するルーチン
Private Sub AddRecipientToNavigation(strAddress, navGroup)
     On Error Resume Next
     Dim recOther 'As Recipient
     Dim fldCalendar 'As Folder
     ' メールアドレスから受信者オブジェクトを生成
     Set recOther = nsSession.CreateRecipient(strAddress)
     ' 名前解決を実行
     recOther.Resolve
     If recOther.Resolved Then
         ' 自分自身は予定表グループに追加しない
         ' Exchange 組織外のアドレスも追加しない
         If recOther.Address = nsSession.CurrentUser.Address _
             Or recOther.AddressEntry.Type <> "EX" Then
             Exit Sub
         End If
         ' 他のユーザーの予定表を取得
         Set fldCalendar = nsSession.GetSharedDefaultFolder(recOther, olFolderCalendar)
         If Not fldCalendar Is Nothing Then
             ' 予定表が取得できたら予定表グループに追加
             navGroup.NavigationFolders.Add fldCalendar
         End If
     End If
End Sub
' 予定表グループを作成・取得するルーチン
Private Function GetNavigationGroup(strGroupName)
     On Error Resume Next
     Dim actExp 'As Explorer
     Dim navModule 'As CalendarModule
     Dim navGroups 'As NavigationGroups
     Dim navGroupT 'As NavigationGroup
     Dim i 'As Integer
     Dim j 'As Integer
     ' 予定表グループを追加するための Explorer オブジェクトを取得
     If olkApp.ActiveExplorer Is Nothing Then
         Dim fldCalendar 'As Folder
         Set fldCalendar = nsSession.GetDefaultFolder(olFolderCalendar)
         Set actExp = fldCalendar.GetExplorer()
     Else
         Set actExp = olkApp.ActiveExplorer
     End If
     ' 予定表モジュールを取得
     Set navModule = actExp.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
     ' 予定表グループのリストを取得
     Set navGroups = navModule.NavigationGroups
     For i = 1 To navGroups.Count
         Set navGroupT = navGroups.Item(i)
         ' 追加しようとしているグループが既に存在していた場合
         If navGroupT.Name = strGroupName Then
             ' 既存の予定表はすべて削除
             With navGroupT.NavigationFolders
                 For j = .Count To 1 Step -1
                     Dim navFolder 'As NavigationFolder
                     Set navFolder = .Item(j)
                     .Remove navFolder
                 Next
             End With
             ' 既存の予定表グループを返す
             Set GetNavigationGroup = navGroupT
             Exit Function
         End If
     Next
     ' 新規に予定表グループを作成して返す
     Set GetNavigationGroup = navGroups.Create(strGroupName)
End Function

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

既定の予定表のみを表示して Outlook を起動するスクリプト

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


こんにちは。
いつも参考にささていただきありがとうございます。

質問よろしくお願いします。

私は社内で365を利用していて、
  沢山のカレンダーを管理しているのですが、
デスクトップにoutlook のカレンダーをワンクリックで開けるように以下のようなショートカットを作ってい利用しています。

“C:\Program Files\Microsoft Office 15\root\office15\outlook.exe” /select outlook:calenders

ただ上記の方法だと、最終利用時に、選んだカレンダーが
  そのまま次回起動時に表示されてしまいます。

毎回リセットされた状態でカレンダーを開く方法などはありますでしょうか?

何卒よろしくお願いします!


Outlook をスクリプトで起動し、既定の予定表を表示することで、ご要望の動作は満たせると思います。
スクリプトは以下のようになります。

' ここをトリプルクリックでスクリプト全体を選択できます。

Const olFolderCalendar = 9
Dim olkApp
Dim fldCal
Set olkApp = CreateObject("Outlook.Application")
Set fldCal = olkApp.Session.GetDefaultFolder(olFolderCalendar)
fldCal.Display

リアルタイムプレビュー表示と添付ファイルプレビューの設定をファイルにエクスポートするスクリプト

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


[ファイル>オプション]にあります[Outlookのオプション]の情報ですが、こちらを別ファイル(テキストやCSV)で見ることは可能でしょうか。

利用想定として、Outlook基本設定の[リアルタイムプレビュー表示機能を有効にする]の項目をAさんはON / BさんはOFF、セキュリティセンターの[添付ファイルのプレビューをオフにする]の項目をAさんはOFF / BさんはONとなっていることを別ファイルで見たいと考えております。

Outlook:2010
  Windows:7 Enterprise SP1

よろしくお願いいたします。


ご要望の 2 つの設定はそれぞれ以下のレジストリに格納されています。

[リアルタイム プレビュー表示機能を有効にする]

キー: HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\14.0\Common\MailSettings
名前: EnableLivePreview

[添付ファイルのプレビューをオフにする]

キー: HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\14.0\Outlook\Preferences
名前: DisableAttachmentPreviewing

これらのレジストリの値をファイルに保存するようなスクリプトを作成すれば、ご要望は満たせるでしょう。
スクリプトは以下のようになります。

' ここをトリプルクリックでスクリプト全体を選択できます。

Option Explicit
On Error Resume Next
Const EXPORT_FILE="c:\temp\test.txt"
' Outlook 2010
Const REG_ENABLELIVEPREVIEW = "HKCU\SOFTWARE\Microsoft\Office\14.0\Common\MailSettings\EnableLivePreview"
Const REG_DISABLEATTACHMENTPREVIEW = "HKCU\SOFTWARE\Microsoft\Office\14.0\Outlook\Preferences\DisableAttachmentPreviewing"
' Outlook 2013
'Const REG_ENABLELIVEPREVIEW = "HKCU\SOFTWARE\Microsoft\Office\14.0\Common\MailSettings\EnableLivePreview"
'Const REG_DISABLEATTACHMENTPREVIEW = "HKCU\SOFTWARE\Microsoft\Office\14.0\Outlook\Preferences\DisableAttachmentPreviewing"
' Outlook 2016
'Const REG_ENABLELIVEPREVIEW = "HKCU\SOFTWARE\Microsoft\Office\14.0\Common\MailSettings\EnableLivePreview"
'Const REG_DISABLEATTACHMENTPREVIEW = "HKCU\SOFTWARE\Microsoft\Office\14.0\Outlook\Preferences\DisableAttachmentPreviewing"
'
Dim WSHShell
Dim iEnableLivePrev
Dim iDisableAttPrev
'
Set WSHShell = CreateObject("WScript.Shell")
'  [リアルタイム プレビュー表示機能を有効にする] の設定取得
iEnableLivePrev = WSHShell.RegRead(REG_ENABLELIVEPREVIEW)
If Err.Number<> 0 Then
     iEnableLivePrev = 1
     Err.Clear
End If
'  [添付ファイルのプレビューをオフにする] の設定取得
iDisableAttPrev = WSHShell.RegRead(REG_DISABLEATTACHMENTPREVIEW)
If Err.Number<> 0 Then
     iDisableAttPrev = 0
End If
'
Dim objFSO
Dim stmLog
Dim astrOnOff : astrOnOff = Array("OFF", "ON")
'
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set stmLog = objFSO.CreateTextFile(EXPORT_FILE)
stmLog.WriteLine "リアルタイムプレビュー表示機能を有効にする = " & astrOnOff(iEnableLivePrev)
stmLog.WriteLine "添付ファイルのプレビューをオフにする = " & astrOnOff(iDisableAttPrev)
stmLog.Close

ビューをファイルにエクスポート・インポートするスクリプト

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


いつも大変お世話になっております。
可能であればマクロ作成をご検討頂きたいのです。
OS:Windows 7 Professional(64bit)
Outlook2013
【ビューの定義をエクスポート(インポート)するマクロ】
【印刷スタイルの定義をエクスポート(インポート)するマクロ】
ビューの定義や印刷スタイルの定義を社内で統一して利用したい。
私が現在設定しているビューを
PC内(Outlook2013)でコピーする事は出来ますが
別PC(Outlook2013)へビューや印刷スタイルの定義を
エクスポート(インポート)する事は出来ないでしょうか?
標準の機能として、これらの定義のエクスポート(インポート)はないようなので
マクロで作成可能であればお願いしたい次第です。
ビューについては
【現在のビューの設定をサブフォルダにコピーするマクロ】や
2014年2月22日 コメントでの要望を受けての
全てのストアのフォルダー階層にアクセス可能な
【現在のビューをすべてのフォルダーに適用するマクロ】
上記の2つのマクロをどうにかすれば可能なのでしょうか?
ご検討の程、よろしくお願い申し上げます。


まず、印刷スタイルの定義ですが、こちらは以下のファイルに保存されています。(ファイルに拡張子はありません)

    c:\users\ユーザー名\AppData\Roaming\Microsoft\Outlook\OutPrnt

このファイルを単にコピーすれば、他の環境に印刷スタイルの定義をコピーすることができます。

次に、ビューの設定ですが、こちらはご指摘のマクロでやっているように、View オブジェクトの XML プロパティの文字列をエクスポート・インポートすれば、他の環境にビューの定義をコピーすることができます。
ただし、自動書式についてはコピーすることはできません。

現在表示しているフォルダーの現在のビュー設定をファイルにエクスポートするスクリプトは以下のようになります。
複数の PC で実行することを想定したため、スクリプトとして実装しました。
この内容をメモ帳などのテキストエディタに貼り付け、拡張子を .vbs として保存し、ダブルクリックして実行してください。

' ここをトリプルクリックでスクリプト全体を選択できます。
Const VIEW_XML = "C:\temp\current.view" ' エクスポート先のファイル名
Dim olkApp
Dim objFSO
Dim curView
Dim stmXml
Dim strXml
Set olkApp = CreateObject("Outlook.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set curView = olkApp.ActiveExplorer.CurrentFolder.CurrentView
strXml = curView.XML
Set stmXml = objFSO.CreateTextFile(VIEW_XML)
' 1 行目はビューの名前と種類
stmXml.WriteLine curView.Name & vbTab & curView.ViewType
stmXml.Write strXml
stmXml.Close

また、上記のスクリプトでエクスポートしたビュー設定を、現在表示しているフォルダーにインポートするスクリプトは以下のようになります。

' ここをトリプルクリックでスクリプト全体を選択できます。
On Error Resume Next
Const VIEW_XML = "C:\temp\current.view" ' インポート先のファイル名
Dim olkApp
Dim objFSO
Dim stmXml
Dim strLine
Dim arrLine
Dim colViews
Dim curView
Set olkApp = CreateObject("Outlook.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set stmXml = objFSO.OpenTextFile(VIEW_XML, 1)
' 1 行目はビューの名前と種類
strLine = stmXml.ReadLine
arrLine = Split(strLine, vbTab)
Set colViews = olkApp.ActiveExplorer.CurrentFolder.Views
Set curView = colViews.Add(arrLine(0), arrLine(1), 0)
If Err.Number = 5 Then ' 同名のビューが存在した場合のエラー処理
    For Each curView In colViews
        ' 同名のビューを検索
        If curView.Name = arrLine(0) Then
            Exit For
        End If
    Next
End If
curView.XML = stmXml.ReadAll
curView.Save
curView.Apply
stmXml.Close