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

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


【使用環境】
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

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

広告

特定の文字列を件名に含むメールを受信した際にその送信者アドレスと受信日時をExcelファイルまたはCSVファイルに保存するマクロ

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


お世話になってます。

いつもありがとうございます。
  参考させていただいています。

勤怠システムとしてVBAを利用したいと思っているんですが
出発メールの管理を考えております。

教えて頂けると幸いでございます。

やりたいこと
①件名に「出発」という文字が含まれるメールが届いたら、届いた時にエクセルへ反映
②エクセルにはメール送信者アドレスと受信時間だけ反映(A2:アドレス、B2:受信時間、を縦に反映)

これを常時自動で行ってくれるマクロはありませんでしょうか?
※出発という文字が含まれるメールが大量に届き追いきれない状況です。

お知恵をお借りしたく、何卒よろしくお願いいたします。

使用環境
win8.1
  office2010


まず、メールが受信された際に自動的にマクロを実行するには Application オブジェクトの NewMailEx イベントを使用します。
次に、メールの件名に特定の文字列が含まれるかどうかを確認するには InStr 関数で MailItem オブジェクトの Subject プロパティを検索します。
そして、Excel ファイルを開くには GetObject を使用し、取得した Workbook オブジェクトの WorksheetCells で値がない行を検索します。
最後に、MailItem オブジェクトの Sender.Address プロパティで取得できる送信者のアドレスと、ReceivedTime プロパティで取得できる受信日時を Cells に書き込み、Save メソッドで保存します。
まとめると以下のようなマクロになります。
なお、Excel ファイルへの書き込みには多少時間がかかり、大量のメールを一度に受信するとマクロの処理が追い付かずに保存されない場合があるため、CSV ファイルに書き込む記述も追加しました。

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

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Const SAVE_KEYWORD = "出発"
     Dim objItem As Object
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     If objItem.MessageClass = "IPM.Note" And InStr(objItem.Subject, SAVE_KEYWORD) > 0 Then
         SaveDateAndSenderToExcelFile objItem
         ' CSV ファイルに保存する場合は以下の記述を使用
         'SaveDateAndSenderToCSVFile objItem
     End If
End Sub
'
Public Sub SaveDateAndSenderToExcelFile(ByVal objItem As MailItem)
     ' Excel ファイルのファイル名を指定
     Const EXCEL_FILE = "c:\temp\depart.xlsx"
     '
     Dim excBook As Object
     Dim excSheet As Object
     Dim iRow As Integer
     ' Excel ファイルを取得
     Set excBook = GetObject(EXCEL_FILE)
     ' 1 つ目のワークシートを取得
     Set excSheet = excBook.Worksheets(1)
     ' あいている行を検索
     iRow = 2
     While excSheet.Cells(iRow, 1) <> ""
         iRow = iRow + 1
     Wend
     ' あいている行に送信者アドレスと受信日時を書き込み
     excSheet.Cells(iRow, 1) = objItem.Sender.Address
     excSheet.Cells(iRow, 2) = objItem.ReceivedTime
     excBook.Save
End Sub
'
Public Sub SaveDateAndSenderToCSVFile(ByVal objItem As MailItem)
     ' CSV ファイルのファイル名を指定
     Const CSV_FILE = "c:\temp\depart.csv"
     ' CSV ファイルを開く
     Open CSV_FILE For Append As #1
     ' CSV ファイルに送信者アドレスと受信日時を追記
     Print #1, objItem.Sender.Address; ","; objItem.ReceivedTime
     Close #1
End Sub

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

メールの本文の指定された行の文字列をもとに Excel で VLookup を実行し、見つかった値をヘッダーに追記して印刷するマクロ

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


初めまして。Outlook VBA初心者です。

以下のようなことは可能でしょうか。

①メール本文内のn行目のキーワードを取得
②キーワードを検索値として指定のエクセルファイルからVLOOKUPで情報を取得
③VLOOKUPで取得した情報をメールのヘッダーに設定し、印刷

エクセルのVBAは少し経験があるのですが、outlookはまだまだ勉強中でなかなか作業が進まず困っております。こういった操作が可能かどうかだけでもご教示いただければ幸いです。


可能です。
順を追って説明しましょう。

まず、①についてですが、メールの本文を含む一般的なテキストにおける「行」とは CRLF (改行コード) で終わる一連の文字列を指します。
そのため、本文の文字列を CRLF で分割し、分割された文字列の n 番目の文字列が n 行目、ということになります。
VBA では Split という関数を使って文字列を分割できます。

次に、②についてですが、Excel のファイルから VLookup で情報を取得するには、Excel の Application オブジェクトの VLookup を使用します。
(厳密にいうと Application の WorksheetFunction プロパティの VLookup メソッドなのですが、WorksheetFunction は省略できるようです。)
ここで、VLookup を使う際には VLookup( Value, “A1:B2”, 2 ) というようにしたくなるのですが、VLookup の 2 番目の引数は範囲指定のオブジェクトを指定する必要があるため、Worksheet オブジェクトの Range プロパティで取得します。

最後に、③についてですが、メールのヘッダーに設定して印刷をするには、メールのユーザー定義プロパティとして取得した情報を追加する必要があります。
ユーザー定義プロパティの追加は MailItemUserProperties プロパティの Add メソッドを使用し、取得した UserProperty オブジェクトの Value プロパティに値を設定します。
なお、同じメールに 2 回実行すると、Add メソッドが失敗するため、Add の前に Find メソッドで既存のプロパティがあるか確認し、存在する場合はそれを再利用するようにしています。

上記の処理をマクロで実装すると以下のようになります。

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

Public Sub PrintWithValueByVLookup()
     ' 読み込む Excel ファイルを指定
     Const EXCEL_FILE = "c:\temp\table.xlsx"
     ' VLookup で検索するシートの番号を指定
     Const VLOOKUP_SHEET = 1
     ' VLookup で検索する範囲を指定
     Const VLOOKUP_RANGE = "A2:B10"
     ' VLookup で値を返す列番号を指定
     Const VLOOKUP_VALUE = 2
     ' メールでキーワードを取得する行数を指定
     Const LOOKUP_LINE = 5
     ' 印刷する際に Excel で取得した値の表題を指定
     Const VALUE_NAME = "ExcelValue"
     '
     Dim objItem As MailItem
     Dim strKey As String
     ' アクティブなウィンドウのアイテムを取得
     If TypeName(ActiveWindow) = "Inspector" Then
         Set objItem = ActiveInspector.CurrentItem
     Else
         Set objItem = ActiveExplorer.Selection(1)
     End If
     ' 指定行からキーワードを取得
     strKey = GetLineByNumber(objItem.Body, LOOKUP_LINE)
     ' 値が取得できたら検索
     If strKey <> "" Then
         Dim excBook As Object
         Dim rgLookup As Object
         Dim varValue As Variant
         ' Excel ファイルを取得
         Set excBook = GetObject(EXCEL_FILE)
         ' VLookup の検索範囲を取得
         Set rgLookup = excBook.Worksheets(VLOOKUP_SHEET).Range(VLOOKUP_RANGE)
         ' VLookup を実行
         varValue = excBook.Application.VLookup(strKey, rgLookup, VLOOKUP_VALUE)
         ' 値が取得できたら処理
         If varValue <> "" And Not varValue Like "エラー*" Then
             Dim usrProp As UserProperty
             ' 取得した値をユーザー定義フィールドに設定
             Set usrProp = objItem.UserProperties.Find(VALUE_NAME)
             If usrProp Is Nothing Then
                 Set usrProp = objItem.UserProperties.Add(VALUE_NAME, olText)
             End If
             usrProp.Value = varValue
             objItem.Save
             ' メールを印刷
             objItem.PrintOut
         Else
             MsgBox "VLookup の検索でエラーが発生しました。"
         End If
     Else
         MsgBox "メッセージにキーワードを見つけられませんでした。"
     End If
End Sub
' 指定された行番号の行を取得
Private Function GetLineByNumber(strBody As String, iLine As Integer)
     Dim arrLines As Variant
     ' 改行コード (CRLF) で本文を分割
     arrLines = Split(strBody, vbCrLf)
     If UBound(arrLines) >= iLine - 1 Then
         ' 指定された行番号の行を返す
         GetLineByNumber = arrLines(iLine - 1)
     Else
         GetLineByNumber = ""
     End If
End Function

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

本文に埋め込まれた画像を除いて添付ファイルをカウントするマクロ

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


添付ファイル数を数えるマクロで、挿入→ファイルの添付で添付したファイルのみ数え、本文に直接貼ったファイルは数えないというようなものは可能ですか?

Attachments.Countで数えようとすると、本文に直接貼ったものを数えてしまい、

返信の引用で画像が貼られている場合はこの画像もカウントしてしまうため困っています


添付ファイルが埋め込み画像かどうかについては、以前記事にした添付ファイルが埋め込み画像かどうかを判断する方法で判断できます。
この方法を使用して現在開いているアイテムの埋め込み画像を除いた添付ファイルの数を数えるマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ShowAttachCount()
     Dim c As Integer
     Dim objAttach As Attachment
     '
     c = 0
     For Each objAttach In ActiveInspector.CurrentItem.Attachments
         If Not IsAttachEmbedded(objAttach) Then
             c = c + 1
         End If
     Next
     '
     MsgBox "添付ファイル数: " & c
End Sub
'
Private Function IsAttachEmbedded(objAttach As Attachment)
     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
     ' フラグが 0 以外なら埋め込み画像
     iAttFlags = objAttach.PropertyAccessor.GetProperty(PR_ATTACH_FLAGS)
     If iAttFlags <> 0 Then
         IsAttachEmbedded = True
     End If
     ' Content ID があれば埋め込み画像
     strAttCID = objAttach.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)
     If strAttCID <> "" Then
         IsAttachEmbedded = True
     End If
     ' OLE オブジェクトなら埋め込み画像
     If objAttach.Type = olOLE Then
         IsAttachEmbedded = True
     End If
End Function

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

他のユーザーの予定表を非公開のものも含めて CSV ファイルにエクスポートするマクロ

Outlook の予定表を CSV ファイルにエクスポートするマクロ Ver 2 のコメントにて以下のご要望をいただきました。


はじめまして。
  他メンバーのスケジュール書き出しに便利に使わせて頂いています。
  以下の方法をご教示いただけないでしょうか。
1.非公開の予定を「非公開」の予定として書き出す方法。
2.空の予定を書きださない方法。
どうかよろしくお願い申し上げます。


まず、2 については AppointmentItemBusyStatus に公開方法が格納されていますので、こちらが olFree である予定を除外することで空き時間となっている予定を書き出さないようにすることができます。

問題は、1 についてです。
他のユーザーの非公開の予定については、Outlook Object Model では AppointmentItem オブジェクトとして取得ができません。
取得ができないということは、存在すらわからないということになります。
しかし、Exchange Web Service (EWS) というインターフェイスにより Exchange サーバーの可用性サービスから空き時間情報を取得すると、非公開の予定の情報も取得できます。
「空き時間情報、件名、場所」の権限がある他のユーザーの予定を CSV にエクスポートするマクロとして EWS でアクセスする方法も公開していますが、こちらの方法だと取得できる情報が件名や場所に限られるため、非公開以外の予定は Outlook Object Model、非公開の予定は EWS で取得することで、ご要望は満たせるかと思います。

マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
'  他人の予定を出力するマクロ
Public Sub ExportOthersCalendar()
     Const OTHERS_CSV_FILE_NAME = "c:\temp\others.csv" ' エクスポートするファイル名を指定してください。
     Dim strUserName As String
     Dim objRecip As Recipient
     Dim objExchUser As ExchangeUser
     Dim fldCalendar As Folder
     Dim strStart As String
     Dim strEnd As String
     Dim dtExport As Date
     Dim objFSO 'As FileSystemObject
     Dim stmCSVFile 'As TextStream
     Dim colAppts As Items
     Dim objAppt As AppointmentItem
     Dim strLine As String
     Dim xmlDoc As Variant
     Dim arrFBResps As Variant
     Dim i, j As Integer
     '
     strUserName = InputBox("ユーザー名またはアドレスを入力してください", "共有されている予定表のエクスポート")
     '
     Set objRecip = Session.CreateRecipient(strUserName)
     objRecip.Resolve
     If Not objRecip.Resolved Then
         MsgBox "ユーザーが特定できませんでした。", vbCritical, "共有されている予定表のエクスポート"
         Exit Sub
     End If
     '
     dtExport = Now ' 来月の予定をエクスポートする場合は Now の代わりに DateAdd("m",1,Now) を使用します。
     ' 月単位ではなく任意の単位にする場合は以下の記述を変更します。
     strStart = Year(Now) & "/" & Month(Now) & "/1 00:00"
     strEnd = DateAdd("m", 1, CDate(strStart)) & " 00:00"
     '
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     Set stmCSVFile = objFSO.CreateTextFile(OTHERS_CSV_FILE_NAME, True)
     ' CSV ファイルのヘッダです。出力するフィールドを増減する場合はこちらも変更してください。
     stmCSVFile.WriteLine """件名"",""場所"",""開始日"",""開始時刻"",""終了日""," & _
         """終了時刻"",""分類項目"",""主催者"",""必須出席者"",""任意出席者"""
     ' フェーズ 1: 予定表フォルダーから出力
     Set fldCalendar = Session.GetSharedDefaultFolder(objRecip, olFolderCalendar)
     Set colAppts = fldCalendar.Items
     colAppts.Sort "[開始日]"
     colAppts.IncludeRecurrences = True
     Set objAppt = colAppts.Find("[開始日] < """ & strEnd & """ AND [終了日] >= """ & strStart & """")
     While Not objAppt Is Nothing
         ' 公開方法が空きでなければ出力
         If objAppt.BusyStatus <> olFree Then
             strLine = """" & objAppt.Subject & _
                 """,""" & objAppt.Location & _
                 """,""" & FormatDateTime(objAppt.Start, vbShortDate) & _
                 """,""" & FormatDateTime(objAppt.Start, vbShortTime) & _
                 """,""" & FormatDateTime(objAppt.End, vbShortDate) & _
                 """,""" & FormatDateTime(objAppt.End, vbShortTime) & _
                 """,""" & objAppt.Categories & _
                 """,""" & objAppt.Organizer & _
                 """,""" & objAppt.RequiredAttendees & _
                 """,""" & objAppt.OptionalAttendees & _
                 """"
             stmCSVFile.WriteLine strLine
         End If
         Set objAppt = colAppts.FindNext
     Wend
     ' フェーズ 2: 空き時間情報から出力
     Set xmlDoc = Nothing
     ' SMTP アドレスを取得するために ExchangeUser オブジェクトを取得
     Set objExchUser = objRecip.AddressEntry.GetExchangeUser
     ' Exchange サーバーの可用性サービスから空き時間を取得
     GetUsersAvailability objExchUser.PrimarySmtpAddress, strStart, strEnd, xmlDoc
     If Not xmlDoc Is Nothing Then
         ' 取得した空き時間を配列に設定
         Set arrFBResps = xmlDoc.DocumentElement.getElementsByTagName("FreeBusyResponse")
         For i = 0 To arrFBResps.Length - 1
             ' 取得が成功したか確認
             If arrFBResps(i).getElementsByTagName("ResponseMessage").Item(0).Attributes.getNamedItem("ResponseClass").Text = "Success" Then
                 Dim arrCalEvents As Variant
                 Dim calEvent As Variant
                 Dim strStatus As String
                 Dim strIsPrivate As String
                 Dim dtCalStart As Date
                 Dim dtCalEnd As Date
                 ' 予定を一つずつ処理
                 Set arrCalEvents = arrFBResps(i).getElementsByTagName("CalendarEvent")
                 For j = 0 To arrCalEvents.Length - 1
                     Set calEvent = arrCalEvents(j)
                     strIsPrivate = GetValue(calEvent, "IsPrivate")
                     strStatus = GetValue(calEvent, "BusyType")
                     ' 非公開の予定、かつ公開方法が空きでなければ出力
                     If strIsPrivate = "true" And strStatus <> "Free" Then
                         dtCalStart = GetDateValue(calEvent, "StartTime")
                         dtCalEnd = GetDateValue(calEvent, "EndTime")
                         strLine = """非公開の予定"",""" & _
                             """,""" & FormatDateTime(dtCalStart, vbShortDate) & _
                             """,""" & FormatDateTime(dtCalStart, vbShortTime) & _
                             """,""" & FormatDateTime(dtCalEnd, vbShortDate) & _
                             """,""" & FormatDateTime(dtCalEnd, vbShortTime) & _
                             """"
                         stmCSVFile.WriteLine strLine
                     End If
                 Next
             End If
         Next
     End If
     stmCSVFile.Close
End Sub
'
'  Exchange サーバーの可用性サービスから空き時間を取得するサブ プロシージャ
Sub GetUsersAvailability(strAddress As String, strStart As String, strEnd As String, xmlDoc As Variant)
     Const EWS_URL = "http:" & "//casserver.example.com/ews/exchange.asmx" ' EWS の URL を指定します。
     Const W3_ORG = "http:" & "//www.w3.org"
     Const SOAP_SCHEMAS = "http:" & "//schemas.xmlsoap.org"
     Const MS_SCHEMAS = "http:" & "//schemas.microsoft.com"
     Dim xmlHttp
     Dim strXmlData As Variant
     Dim i As Integer
     ' EWS リクエスト生成
     Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
     strXmlData = "<?xml version=""1.0"" encoding=""utf-8""?>" & _
         "<soap:Envelope xmlns:xsi=""" & W3_ORG & "/2001/XMLSchema-instance""" & _
         " xmlns:xsd=""" & W3_ORG & "/2001/XMLSchema""" & _
         " xmlns:soap=""" & SOAP_SCHEMAS & "/soap/envelope/""" & _
         " xmlns:t=""" & MS_SCHEMAS & "/exchange/services/2006/types"">" & _
         "<soap:Body>" & _
         "<GetUserAvailabilityRequest xmlns=""" & MS_SCHEMAS & "/exchange/services/2006/messages""" & _
         " xmlns:t=""" & MS_SCHEMAS & "/exchange/services/2006/types"">" & _
         "<t:TimeZone xmlns=""" & MS_SCHEMAS & "/exchange/services/2006/types"">" & _
         "<Bias>-540</Bias>" & _
         "<StandardTime><Bias>0</Bias><Time>00:00:00</Time><DayOrder>0</DayOrder>" & _
          "<Month>0</Month><DayOfWeek>Sunday</DayOfWeek></StandardTime>" & _
         "<DaylightTime><Bias>-60</Bias><Time>00:00:00</Time><DayOrder>0</DayOrder>" & _
          "<Month>0</Month><DayOfWeek>Sunday</DayOfWeek></DaylightTime>" & _
         "</t:TimeZone>" & _
         "<MailboxDataArray>"
     ' 取得するメールボックスを追加
     strXmlData = strXmlData & _
         "<t:MailboxData><t:Email><t:Address>" & strAddress & "</t:Address></t:Email>" & _
         "<t:AttendeeType>Required</t:AttendeeType><t:ExcludeConflicts>false</t:ExcludeConflicts>" & _
         "</t:MailboxData>"
     ' 取得する期間を設定
     strStart = Format(strStart, "yyyy-mm-ddThh:nn:ss")
     strEnd = Format(strEnd, "yyyy-mm-ddThh:nn:ss")
     ' その他の条件を設定
     strXmlData = strXmlData & _
         "</MailboxDataArray>" & _
         "<t:FreeBusyViewOptions>" & _
         "<t:TimeWindow>" & _
         "<t:StartTime>" & strStart & "</t:StartTime>" & _
         "<t:EndTime>" & strEnd & "</t:EndTime>" & _
         "</t:TimeWindow>" & _
         "<t:MergedFreeBusyIntervalInMinutes>60</t:MergedFreeBusyIntervalInMinutes>" & _
         "<t:RequestedView>DetailedMerged</t:RequestedView>" & _
         "</t:FreeBusyViewOptions>" & _
         "</GetUserAvailabilityRequest>" & _
         "</soap:Body>" & _
         "</soap:Envelope>"
     ' リクエスト送信
     xmlHttp.Open "POST", EWS_URL, False
     xmlHttp.setRequestHeader "Content-Type", "text/xml"
     xmlHttp.Send strXmlData
     If xmlHttp.Status = "200" Then
         Set xmlDoc = CreateObject("MSXML2.DOMDocument")
         Debug.Print xmlHttp.responseText
         If xmlDoc.LoadXML(xmlHttp.responseText) Then
             ' OK ならここで終了
             Exit Sub
         End If
     End If
     ' エラーなら Nothing を設定
     Set xmlDoc = Nothing
End Sub
'
Function GetValue(xmlNode, strName)
     On Error Resume Next
     Dim arrNodes
     Set arrNodes = xmlNode.getElementsByTagName(strName)
     If arrNodes.Length = 0 Then
         GetValue = ""
     Else
         GetValue = arrNodes(0).Text
     End If
End Function
'
Function GetDateValue(xmlNode, strName)
     On Error Resume Next
     Dim arrNodes
     Dim strDate
     Set arrNodes = xmlNode.getElementsByTagName(strName)
     If arrNodes.Length = 0 Then
         GetDateValue = ""
     Else
         strDate = arrNodes(0).Text
         strDate = Replace(strDate, "-", "/")
         strDate = Replace(strDate, "T", " ")
         GetDateValue = CDate(strDate)
     End If
End Function

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

Outlook 2016/2013 の累積的な修正プログラム 2018 年 7 月分がリリース

7/3 に Outlook 2016 および Outlook 2013 の累積的な修正プログラムがリリースされました。

以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

2018 年 7 月 3日更新プログラム Outlook 2016 (KB4022230)
5 件の不具合修正が行われています。

Outlook 2016 用 Microsoft Exchange Add-in の修正

2018 年 7 月 3日更新プログラム Office 2016 (KB3191864)
1 件の Outlook に関する不具合の修正が行われています。

Office 2013

Outlook 2013 の修正

2018 年 7 月 3日は、Outlook 2013 (KB4022242) の更新します。
2 件の不具合修正が行われています。

選択したフォルダーとそのサブフォルダーのすべてのアイテムを HTML ファイルとして連番付きで保存するマクロ

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


突然のコメントを失礼いたします。
  「選択したメッセージを MSG ファイルまたは RTF ファイルとして保存するマクロ」を拝見し、
  利用させていただきたいと思うのですが、
  同様の動作で、追加で下記を実現する方法をご教示いただけないでしょうか。
・受信トレイの下の、任意の複数フォルダを選択し、各フォルダ直下の全てのメールを、そのフォルダ階層を保持したまま、任意の保存先に保存する。
・メッセージをHTML形式で保存する。
お手数をおかけして申し訳ありませんが、お知恵を拝借いただけますと幸いです。
  以上、何卒よろしくお願いいたします。


何度も申し訳ありません。「選択したフォルダーとそのサブフォルダーのすべてのアイテムを MSG ファイルとして保存するマクロ」も参照したところ、 ‘ファイルをフォルダに保存 の箇所を、下記とすればHTML形式で保存ができました。大変失礼いたしました。
objItem.SaveAs strFileName & “.html”, olHTML
もう一点、実現できていないことが、メールの保存時に、各フォルダ内のメールの件名の頭に、受信時間が最も古いものから順に番号を付けたい(例:”1_XXXXX.html”、”2_XXXXX.html”…)という要件です。
もし、実現方法がありましたら、ご教示いただけますと幸いです。
以上、何卒よろしくお願いいたします。


受信時間が最も古いものから順に連番を付けるには、Items オブジェクトの Sort メソッドで受信日時により並べ替えを行い、その順番で連番を付与します。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
'
Sub SaveCurrentFolderAndSubToDiskHTML()
     Const SAVE_PATH = "c:\temp\" ' 保存するフォルダのパス。最後に必ず \ をつける
     SaveFolderRecursiveHTML ActiveExplorer.CurrentFolder, SAVE_PATH
End Sub
' フォルダーのアイテムを再帰的に保存するルーチン
Private Sub SaveFolderRecursiveHTML(objFolder As Folder, strSavePath As String)
     On Error Resume Next
     Dim colItems As Items
     Dim objItem 'As MailItem
     Dim strFileName As String
     Dim c As Integer
     Dim i As Integer
     Dim arrErrChars
     Dim objFSO
     Dim objSubFolder As Folder
     arrErrChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
     ' アイテムを受信日時の古い順に並べ替える
     Set colItems = objFolder.Items
     colItems.Sort "[受信日時]", False
     ' 連番の初期値設定
     c = 1
     '
     For Each objItem In colItems
         ' ファイル名を件名から作成
         strFileName = c & "_" & objItem.Subject
         ' ファイル名として不適切な文字を _ に置き換える
         For i = 0 To UBound(arrErrChars)
             strFileName = Replace(strFileName, arrErrChars(i), "_")
         Next
         ' ファイル名が 260 文字を超えないようにする
         strFileName = Left(strSavePath & strFileName, 250)
         ' ファイルをフォルダに保存
         objItem.SaveAs strFileName & ".html", olHTML
         c = c + 1
     Next
     '
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     ' サブフォルダーを保存
     For Each objSubFolder In objFolder.Folders
         ' ディスク上にフォルダーが存在しなければ作成する
         If Not objFSO.FolderExists(strSavePath & objSubFolder.Name) Then
             objFSO.CreateFolder strSavePath & objSubFolder.Name
         End If
         SaveFolderRecursiveHTML objSubFolder, strSavePath & objSubFolder.Name & "\"
     Next
End Sub

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