OUTLOOK VBA ある日付の複数のアカウントの予定（グループスケジュール）をすべてエクスポートもしくは印刷する

たとえば会社で会議室や社用車の予約をOUTLOOKの予定表の機能で管理している場合があります。
しかし、この会議室や社用車が多いと、どうしても一覧性にかけてしまいます。
しかもOUTLOOKの標準の印刷では一度に一アカウントしかできません。
そこでCSVに開始日時が特定の日の予定をRTF、CSVに出力するVBAを作りました。

使い方

出力したい予定表の設定と検索条件（フィルター文字列）の決定

1. 出力したい予定表の表示 Outlookを起動し、出力したい(グループ)スケジュール表の候補を検索して表示し、さらにチェックを入れて実際の表示させておくこと(出力したい期間を視認するため、出力したい日付の部分を表示させた方がよい)参考(個人の場合)複数の予定表を同時に表示する参考(法人等の組織)Outlook のグループ スケジュールの使用方法
2. フィルターの設定 指定したい日付の区間をsFilterに定める。

指定した日の午前零時以降の開始日時のものを取得する。として検索をかける。(restrict)

"[Start] >= '" & Format(#11/28/2017#, "yyyy/MM/dd") & "'"

最初は必ずこうなる 日付は日付リテラル形式といいナンバー記号 月/日/年 ナンバー記号で囲む。午前零時からなのでFormatの表示形式は yyyyy/MM/dd Mが大文字。
次に AND形式で終端を決める。
たとえば11/28だけなら29日の零時より前に開始日時があるから

& " AND [Start] < '" & Format(#11/29/2017#, "yyyy/MM/dd") & "'"

とする ANDの前には必ずスペースが入る。たとえば期間にしたい場合、11月29日を含むのなら

& " AND [Start] < '" & Format(#11/30/2017#, "yyyy/MM/dd") & "'

を追加する。

1. 出力したいファイル名の指定 Const consStrListFile = "C:\hoge\OutlookSchedule(AppointimentItem)ListUTF8.txt"
2. 出力するアカウントのリスト Const constrAccountList = "C:\hoge\ScheduleExpAccList.txt"
3. 出力ファイルの場所 Const consstrSaveDrive = "C:\hoge\"
4. 出力したい予定表の確認 Step1 Blockでイミディエイトに希望のするアカウントが表示されているか確認する Step2 Arに出力したいアカウント名の配列を代入する。Step1でイミディエイトWindowにArray式を作ってあるため、それが正しければそれを代入するか、修正して代入する。 ちなみにサンプルコードはとあるインターナショナルレスキューがOutlookを使っていた場合を想定

Note1

共有アカウントと会議室といった複数のグループに同じアカウントを登録している場合、CSVのリストに複数出力されます。

Note2 現在の問題点

個人の予定表の定期的な予定は当日が対象外でも出力されます。またVcf形式への出力もうまくいきません。しかし一覧で取得することが目的なのでこれはいずれわかったら改善します。

Note 3 一度リスティングしたあと

一度リスティングすると、非表示の状態(表示のためのチェックを外した状態)にしていても拾うことができます。（ただしリストから外すと不可）

Note4 神への印刷

紙に印刷するときはmyItem.PrintOutを外すといいです。ただし定期的な予定が無関係に出力されるため、現時点ではコメント化しています。PDFだから関係がないのであれば、外してもいいと思います。

PrintSchedule

Sub PrintSchedule()
'For Outlook VBA
'指定した区間の複数のアカウントのスケジュールをスケジュールごとにmsg(unicode形式)とまとめてテキストにリスト形式で出力します。
'使い方
'1.表示 Outlookを起動し、出力したいスケジュール表にチェックを入れて表示させておくこと(出力したい期間を視認するため、出力したい日付の部分を表示させた方がよい)
'2.フィルターの設定 指定したい日付の区間をsFilterに定める。
'開始日時で指定した日の午前零時以降とするので
'"[Start] >= '" & Format(#11/28/2017#, "yyyy/MM/dd") & "'"
'ここは必ずこうなる 日付は日付リテラル形式といいナンバー記号 月/日/年 ナンバー記号で囲む。午前零時からなのでFormatの表示形式は yyyyy/MM/dd
'次に AND形式で終端を決めるたとえば11/28だけなら29日の零時より前に開始日時があるから
'& " AND [Start] < '" & Format(#11/29/2017#, "yyyy/MM/dd") & "'"
'とする ANDの前には必ずスペースが入る。たとえば期間にしたい場合、11月29日を含むのなら
'& " AND [Start] < '" & Format(#11/30/2017#, "yyyy/MM/dd") & "'"
'にする
'出力したいファイル名の指定 Const consStrListFile = "C:\hoge\OutlookSchedule(AppointimentItem)ListUTF8.txt"
'出力するアカウントのリスト Const constrAccountList = "C:\hoge\ScheduleExpAccList.txt"
'出力ファイルの場所 Const consstrSaveDrive = "C:\hoge\"
'Step1 Blockでイミディエイトに希望のするアカウントが表示されているか確認する
'Step2 Arに出力したいアカウント名の配列を代入する。Step1でイミディエイトにArray式を作ってあるため、それが正しければそれを代入するか、修正して代入する。
'Note 共有アカウントと会議室といった複数のグループに同じアカウントを登録している場合、CSVのリストに複数出力されます。
'Note 一度リスティングすると、非表示の状態にしていても拾うことができます。（ただしリストから外すと不可）
'Note 紙に印刷するときはmyItem.PrintOutを外すといいです。
Dim NS As NameSpace: Set NS = Application.GetNamespace("MAPI")
Dim olStores As Outlook.Stores
Dim olStore As Outlook.Store
Dim olViews As Outlook.Views, olView As Outlook.View, olWin
Dim Ain As Outlook.Inspector, AEXs As Outlook.Explorers, AEX As Outlook.Explorer
Dim OlNAViPane As Outlook.NavigationPane, olNAVFolders, olNAVFolder As Outlook.NavigationFolder, oFolder As Outlook.Folder
Dim olNavMods As Outlook.NavigationModules, olNavMod As Outlook.NavigationModule, olNAVGs As Outlook.NavigationGroups, olNAVG As Outlook.NavigationGroup
Dim CNT As Long, i As Long
Dim dt As Date, bl As Boolean
Dim myItem As AppointmentItem
Dim sFilter As String: sFilter = "[Start] >= '" & Format(#11/28/2017#, "yyyy/MM/dd") & "'" & " AND [Start] < '" & Format(#11/29/2017#, "yyyy/MM/dd") & "'"
'取り出したい開始日付の区間を入れる
Debug.Print "sfilter =", sFilter
Dim ar As Variant, ia As Long
'Dim sr As ADODB.Stream: Set sr = New ADODB.Stream '参照設定したときはこちらを使う
Dim sr : Set sr = CreateObject("ADODB.Stream")
'Dim fs As FileSystemObject: Set fs = New Scripting.FileSystemObject '参照設定したときはこちらを使う
Dim fs : Set sr = CreateObject("Scripting.FileSystemObject")
Const consstrListFile = "C:\hoge\OutlookSchedule(AppointimentItem)ListUTF8.txt"
Const constrAccountList = "C:\hoge\ScheduleExpAccList.txt"
Const consstrSaveDrive = "C:\hoge\"
On Error Resume Next
If fs.FileExists(consstrListFile) = False Then fs.CreateTextFile consstrListFile, True, True
sr.LineSeparator = adCRLF
sr.Charset = "UTF-8" 'UTF-8に設定
sr.Mode = adModeReadWrite
sr.Type = adTypeText
sr.Open
Set AEX = Application.ActiveExplorer

'Objectの順番AEx>>Navigationpane>>Modules>>Module>>Grops>>Group>>NavigationFolders>>folder>>CurrentView>>Folder>Item
Debug.Print AEX.NavigationPane.IsCollapsed
Debug.Print AEX.NavigationPane.Modules.Count
Set olNavMods = AEX.NavigationPane.Modules
Set olNavMod = olNavMods.Item("予定表")
Set olNAVGs = olNavMod.NavigationGroups 'これは自動的には補完されない。隠しオブジェクトになっている。 OL2013 32Bitで確認

'Step1 Block 出力されるアカウントが表示されているかを確認する
CNT = 1: buf = "": buf = "Array("
For Each olNAVG In olNAVGs
Set olNAVFolders = olNAVG.NavigationFolders
For Each olNAVFolder In olNAVFolders
buf = buf & """" & olNAVFolder.DisplayName & """" & ","
Debug.Print CNT, olNAVFolder.DisplayName
Next
CNT = CNT + 1
Next
Debug.Print Mid(buf, 1, Len(buf) - 1) & ")"
Stop

'Step2 Block アカウントリスト配列の代入決定
'ここで取り出したいスケジュールの名前を配列に代入する。イミディエイトのArrayを活用する
'サンプルは見栄えを考慮してアンダーバーで改行しているが、24しか使えないので、Arrayは考慮していない。
'しかしVBEの1行の限界を超えると編集できないので、その場合は適宜改行が必要となる。
'なおサンプルはサンダーバード2015の登場機体のスケジュール表である
ar = Array("TB-1_ThunderBird1", _
"TB-1_ThunderBird2", _
"TB-3_SpaceAstronauts_ThunderBird3", _
"TB-4_AquaNauts", _
"TB-5_SpaceWorkStation", _
"TIOP_TraycyIsland_OperationRoom", _
"TIBR_TraycyIsland_BrainsLab", _
"FAB-1_PanelopeViehcle", _
"TB_X_Thinderbird_Shadow")
Stop '<うまくいくようになったら外す

'Main Block---[Outlook VBA]--------------------
sr.WriteText "インデックス" & "," & "DisplayName"
For ia = LBound(ar) To UBound(ar)
sr.WriteText ia & vbTab & "," & ar(ia) & vbCrLf, adWriteChar
Next ia

sr.WriteText """以上"",""予定表出力対象アカウントリスト""", adWriteLine
sr.SaveToFile constrAccountList
sr.Close
sr.Open
'Main Block---[Outlook VBA]--------------------
sr.WriteText "インデックス" & "," & "DisplayName", adWriteLine
For ia = LBound(ar) To UBound(ar)
sr.WriteText ia & vbTab & "," & ar(ia) & vbCrLf, adWriteChar
Next ia
sr.WriteText """以上"",""予定表出力対象アカウントリスト""", adWriteLine
sr.SaveToFile constrAccountList
sr.Close
sr.Open
sr.WriteText "予定表のアカウント,FolderName,開始,終了,Sub,本文,終日,期間,定期の予定か,場所,ビジーステータス,フィルター", adWriteLine
For Each olNAVG In olNAVGs
Set olNAVFolders = olNAVG.NavigationFolders
For Each olNAVFolder In olNAVFolders
Debug.Print olNAVFolder.DisplayName, "Line:107"
bl = False
For ia = LBound(ar) To UBound(ar)
If olNAVFolder.DisplayName = ar(ia) Then bl = True: Exit For
Next ia
If bl Then
Debug.Print olNAVFolder.DisplayName, "Line:113"
Set oFolder = olNAVFolder.Folder
Set olView = oFolder.CurrentView
If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description: Err.Clear
For Each myItem In oFolder.Items.Restrict(sFilter)
'個別のファイル形式出力
'VCF形式olVCardはローカルにない予定は保存できない。というかあまり動かない。
On Error Resume Next
myItem.SaveAs consstrSaveDrive & Format(myItem.Start, "yyyyMMddhhmm") & Replace(replaceNGchar(olNAVFolder.DisplayName & "_" & oFolder.Name & "_" & myItem.Subject, "_"), ".", "_", 1, -1, vbTextCompar) & ".vcf", olVCard
'If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
'myItem.SaveAs consstrSaveDrive & Format(myItem.Start, "yyyyMMddhhmm") & Replace(Replace(oFolder.Name & myItem.Subject, "/", "_", 1, -1, vbTextCompare), " ", "", 1, -1, vbTextCompare) & ".txt", olText 'テキスト形式はRTFの埋め込みタグだらけで見づらい
myItem.SaveAs consstrSaveDrive & Format(myItem.Start, "yyyyMMddhhmm") & Replace(replaceNGchar(olNAVFolder.DisplayName & "_" & oFolder.Name & "_" & myItem.Subject, "_"), ".", "_", 1, -1, vbTextCompar) & ".rtf", olRTF
myItem.SaveAs consstrSaveDrive & Format(myItem.Start, "yyyyMMddhhmm") & Replace(replaceNGchar(olNAVFolder.DisplayName & "_" & oFolder.Name & "_" & myItem.Subject, "_"), ".", "_", 1, -1, vbTextCompar) & "_U8.msg", olMSGUnicode
'myItem.PrintOut 'ここで印刷することもできる。ただし件数が多いと1件1枚なので、大量に紙を消費するが、個人だと問題ないかもしれない。
'テキストストリーム書き込み
sr.WriteText Left(olNAVFolder.DisplayName, 50) & "," & oFolder.Name & "," & myItem.Start & "," & myItem.End & "," & Left(myItem.Subject, 50) & "," _
& Replace(Replace(myItem.Body, ",", "", 1, -1, vbTextCompare), Chr(10), "", 1, -1, vbTextCompare) & "," & myItem.AllDayEvent & "," & myItem.Duration & "," & myItem.IsRecurring & "," & myItem.Location & "," _
& myItem.BusyStatus & "," & _
sFilter, adWriteLine

'イミディエイトに表示
Debug.Print "hit", myItem.Subject

Debug.Print "hit", myItem.Start, myItem.AllDayEvent, myItem.End, myItem.Duration, myItem.Body
Next
End If
Next
Next
'ストリーム保存 UTF-8 CSV
sr.SaveToFile consstrListFile, adSaveCreateOverWrite
sr.Close
Set sr = Nothing
Set fs = Nothing
End Sub

Public Function replaceNGchar(ByVal sourceStr As String, _
Optional ByVal replaceChar As String = "") As String
'ファイル名でバグが起きる文字(全部ではない)が削除する関数
'以前と変わらないがVBA用に,1,-1,vbTextCompare)を追加
Dim tempStr As String

tempStr = sourceStr
tempStr = Replace(tempStr, "\", replaceChar,1,-1,vbTextCompare)
tempStr = Replace(tempStr, "/", replaceChar,1,-1,vbTextCompare)
tempStr = Replace(tempStr, ":", replaceChar,1,-1,vbTextCompare)
tempStr = Replace(tempStr, "*", replaceChar,1,-1,vbTextCompare)
tempStr = Replace(tempStr, "?", replaceChar,1,-1,vbTextCompare)
tempStr = Replace(tempStr, """", replaceChar,1,-1,vbTextCompare)
tempStr = Replace(tempStr, "<", replaceChar,1,-1,vbTextCompare)
tempStr = Replace(tempStr, ">", replaceChar,1,-1,vbTextCompare)
tempStr = Replace(tempStr, "|", replaceChar,1,-1,vbTextCompare)
tempStr = Replace(tempStr, "[", replaceChar,1,-1,vbTextCompare)
tempStr = Replace(tempStr, "]", replaceChar,1,-1,vbTextCompare)

replaceNGchar = tempStr
End Function

OUTLOOKの基本

基本的な各オブジェクトへのアプローチは
OUTLOOK VBA オブジェクトまとめ
にまとめてあります。