深い階層のフォルダーを一度に作成するマクロ

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


お世話になっております。Outlook 2013 または 2016 で、受信トレイのサブフォルダーとして作成したフォルダー A に対して、さらに多階層のサブフォルダーを一括作成したいと考えています。
具体的には、フォルダー A のサブフォルダーとしてサブフォルダー B を、そして、サブフォルダー B のサブフォルダーとしてさらにサブフォルダー C を、、、という感じで、3~4 階層程度のサブフォルダーを作成する方法をご教示くださいますようお願いいたします。
よろしくお願いします。



Outlook の標準機能ではフォルダーは 1 度に 1 つしか作れないため、ご要望のような動作を満たすにはマクロを作る必要があります。
例えば、現在選択中のフォルダーの下に、入力した文字列を ¥ で区切ったフォルダー階層を作成するマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub CreateDeepSubFolder()
    On Error Resume Next
    Dim fldRoot As Folder
    Dim fldSub As Folder
    Dim strPath As String
    Dim astrFolders As Variant
    Dim strSub As Variant
    '
    strPath = InputBox("フォルダー パス")
    If strPath <> "" Then
        astrFolders = Split(strPath, "¥")
        Set fldRoot = ActiveExplorer.CurrentFolder
        For Each strSub In astrFolders
            Set fldSub = Nothing
            Set fldSub = fldRoot.Folders(strSub)
            If fldSub Is Nothing Then
                Set fldSub = fldRoot.Folders.Add(strSub)
            End If
            Set fldRoot = fldSub
        Next
    End If
End Sub

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

会議出席依頼にフラグを付けるマクロ

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


Outlook2010 で会議出席依頼(MeetingItem)を受信した時に、フラグを付ける(開始日は受信日、期限は会議の日)マクロを作りたいのですが、どうすればよいのでしょうか?



Outlook Object モデルの MeetingItem にはフラグを設定するためのメソッドやプロパティが用意されていません。
そのため、MeetingItem にフラグを付けるには、PropertyAccessor.SetProperty によりいくつかの MAPI プロパティを設定する必要があります。
ご要望のマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objItem As Variant
    Set objItem = Session.GetItemFromID(EntryIDCollection)
   
    If TypeName(objItem) = "MeetingItem" Then
        SetStartAndDueDate objItem
    End If
End Sub
'
Private Sub SetStartAndDueDate(ByVal meetItem As MeetingItem)
    Const PidLidToDoTitle = "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/85A4001E"
    Const PidLidTaskStartDate = "http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81040040"
    Const PidLidTaskDueDate = "http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81050040"
    Const PidLidReminderSet = "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8503000B"
    Const PR_TODO_ITEM_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x0E2B0003&quot;
    With meetItem.PropertyAccessor
        .SetProperty PidLidToDoTitle, meetItem.Subject
        .SetProperty PidLidTaskStartDate, Now
        .SetProperty PidLidTaskDueDate, meetItem.GetAssociatedAppointment(False).Start
        .SetProperty PidLidReminderSet, True
        .SetProperty PR_TODO_ITEM_FLAGS, 1
    End With
    meetItem.Save
End Sub

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

メーリングリスト経由で送信されたメールの実際の送信者で振り分けを行う検索フォルダーを作成するマクロ

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


OUTLOOK2010を使用しています。 検索フォルダ―機能を使用して、差出人毎に自動的にフォルダー分けを行っているのですが、
差出人がメーリングリストを使用して送信した場合に、振り分けたフォルダーから漏れてしまい 困っています。

なお、使用しているメーリングリストで送信されたメールを受信したメールを表示すると、送信者の情報の所に、
『XXXX@ドメイン が次の人の代理で送信しました: 送信者メールアドレス@ドメイン』のように表示されます。

また、メールヘッダを確認したところ、以下のようになっていました。
From :送信者メールアドレス@ドメイン
Sender:XXXX@ドメイン

この情報から推測すると、検索フォルダー機能は、fromではなくSenderを検索しているようです。

このようなメーリングリストのメールを検索フォルダー機能で正しく振り分ける方法は無いでしょうか?



Outlook の通常の検索フォルダーの条件で差出人を指定した場合、ご指摘の通りヘッダーの From ではなく Sender が検索対象となります。
通常の方法で From を検索対象とする検索フォルダーは作成できないのですが、マクロで作成することができます。
具体的には AdvancedSearch メソッドで高度な検索でも指定できないプロパティの検索条件を指定し、生成された Search オブジェクトの Save メソッドにより検索フォルダーとして保存します。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public bSearchInProgress As Boolean
'
Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
    bSearchInProgress = False
End Sub
'
Public Sub CreateSearchFolderForFrom()
    Dim strFrom As String
    Dim strFilter As String
    Dim objSrch As Search
    strFrom = InputBox("差出人アドレス:")
    strFilter = "http://schemas.microsoft.com/mapi/proptag/0x0065001E like '%" & strFrom & "%'"
    Set objSrch = Application.AdvancedSearch("Inbox", strFilter, True)
    bSearchInProgress = True
    While bSearchInProgress
        DoEvents
    Wend
    objSrch.Save strFrom
End Sub

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

空き時間情報のみの権限を持つ予定表のアイテム数を取得する方法

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


はじめまして。Outlookマクロについて頼れるサイトとして、こちらのサイトで学んでいます。
Outlookのマクロで簡単にできそうなことで行き詰っています。
1 共有を得ていない方の予定表の一定期間のアイテム数を取得したいのですが、共有している場合は簡単に取得できるのに、うまくいきません。方法はあると思うのですが。
2 次善の手段として、予定表でステイタスバーに表示される「ビューのアイテム数」を取得したいのですが、これもわかりません。どのオブジェクトの何ていうプロパティか、教えてください。
1でも2でも、ご教示頂けると助かります。是非ともよろしくお願いします。



「空き時間情報、件名、場所」の権限がある他のユーザーの予定を一括で表示するマクロの記事で説明している通り、Exchange 環境でフォルダーのアクセス権限が「空き時間情報、件名、場所」となっている場合、EWS でアクセスする必要があります。
引数として取得したいユーザーのアドレスと開始日、終了日を指定すると、予定の件数を取得する関数を作りました。
EWS_URL には Exchange サーバーの EWS の URL を指定します。
また、 GetFreeBusyCountTest は動作を説明するためのサンプルになります。

' ここをトリプルクリックでマクロ全体を選択できます。
'
Private Function GetFreeBusyCount(strUser As String, dtStart As Date, dtEnd As Date) As Integer
    On Error Resume Next
    ' EWS の URL を指定します。
    Const EWS_URL = "https://casserver.example.com/ews/exchange.asmx"
    Dim xmlHttp
    Dim strXmlData As Variant
    Dim strStart As String
    Dim strEnd As String
    Dim xmlDoc
    Dim i As Integer
    ' EWS リクエスト生成
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    strXmlData = "<?xml version=""1.0"" encoding=""utf-8""?>" & _
        "<soap:Envelope xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance""" & _
        " xmlns:xsd=""http://www.w3.org/2001/XMLSchema""" & _
        " xmlns:soap=""http://schemas.xmlsoap.org/soap/envelope/""" & _
        " xmlns:t=""http://schemas.microsoft.com/exchange/services/2006/types"">" & _
        "<soap:Body>" & _
        "<GetUserAvailabilityRequest xmlns=""http://schemas.microsoft.com/exchange/services/2006/messages""" & _
        " xmlns:t=""http://schemas.microsoft.com/exchange/services/2006/types"">" & _
        "<t:TimeZone xmlns=""http://schemas.microsoft.com/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>" & strUser & "</t:Address></t:Email>" & _
        "<t:AttendeeType>Required</t:AttendeeType><t:ExcludeConflicts>false</t:ExcludeConflicts>" & _
        "</t:MailboxData>"
    ' 取得する期間を設定
    strStart = Format(dtStart, "yyyy-mm-ddThh:nn:ss")
    strEnd = Format(dtEnd, "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 ' , strDom & "\" & strUser, strPass
    xmlHttp.setRequestHeader "Content-Type", "text/xml"
    xmlHttp.Send strXmlData
    If xmlHttp.Status = "200" Then
        Set xmlDoc = CreateObject("MSXML2.DOMDocument")
        If xmlDoc.LoadXML(xmlHttp.responseText) Then
            ' OK なら件数を取得
            Set arrFBResps = xmlDoc.DocumentElement.getElementsByTagName("FreeBusyResponse")
            GetFreeBusyCount = arrFBResps(0).getElementsByTagName("CalendarEvent").Length
            Exit Function
        End If
    End If
    ' エラーなら 0 件とする
    GetFreeBusyCount = 0
End Function
'
Public Sub GetFreeBusyCountTest()
    On Error GoTo ErrorHandler
    Dim strUser As String
    Dim strStart As String
    Dim dtStart As Date
    Dim strEnd As String
    Dim dtEnd As Date
    Dim cFreeBusy As Integer
    '
    strUser = InputBox("取得するユーザーのアドレス:")
    strStart = InputBox("開始日")
    dtStart = CDate(strStart)
    strEnd = InputBox("終了日")
    dtEnd = DateAdd("d", 1, CDate(strEnd))
    cFreeBusy = GetFreeBusyCount(strUser, dtStart, dtEnd)
    MsgBox "予定の件数は " & cFreeBusy & " 件です。"
    Exit Sub
ErrorHandler:
    MsgBox Err.Description
End Sub

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

Excel のデータをもとに会議の変更通知やキャンセル通知を送信するマクロ

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


はじめまして。このサイトを活用させていただき、いろいろ勉強させていただいています。
このサイトを参考に、Outlook2007(Exchange環境)で会議出席依頼を発信するExcelマクロツールを作成しましたが、発信した会議出席依頼を、件名と開催時刻と終了時刻をキーに特定して、キャンセルの上、キャンセル通知を発信するマクロをご教示お願いいたします


はじめまして。「Excel のデータをもとに会議出席依頼を送信するマクロ」 を使用させていただいてますが以下の内容もできないでしょうか?
1.エクセル記載の日付、開始時間、終了時間、件名、場所が一致する会議予定を削除、又はキャンセル通知を送信する
2.エクセル記載の日付、開始時間、終了時間、件名、場所が一致する会議予定の日付、又は開始/終了時間を変更 する
ご教授頂けると助かります。よろしくお願い致します。



Outlook で変更通知を送信するには、元の会議アイテムに変更を加えて、改めて Send メソッドを実行します。
また、キャンセル通知を送信するには、元の会議アイテムの MeetingStatus を olMeetingCanceled (5) に変更し、Send メソッドを実行します。
以下のような Excel シートをもとに会議の変更およびキャンセルを行う Excel のマクロを作成しました。

  A B C D E F G H
1 日付 開始時刻 終了時刻 件名 場所 変更日付 変更開始 変更終了
2 2016/10/03 10:00 11:00 会議A 会議室1 2016/10/03 11:00 12:00
3 2016/10/04 11:00 12:00 会議B 会議室2      

変更日付が設定されている会議は変更通知を送信し、設定されていない会議はキャンセル通知を送信して削除します。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ModifyCancelMeetingRequest()
    Const olFolderCalendar = 9
    Const olMeetingCanceled = 5
    Dim olkApp 'As Outlook.Application
    Dim fldCalendar 'As Outlook.Folder
    Dim objAppt 'As Outlook.AppointmentItem
    Dim r As Integer
    Dim dtAppt As Date
    Dim strStart As String
    Dim strEnd As String
    Dim strSubject As String
    Dim strLocation As String
    '
    Set olkApp = CreateObject("Outlook.Application")
    Set fldCalendar = olkApp.Session.GetDefaultFolder(olFolderCalendar)
    r = 2
    With Sheet1
        ' 日付のセルに値がある間繰り返す
        While .Cells(r, 1) <> ""
            ' セルで指定された条件の予定を検索
            Set objAppt = fldCalendar.Items.Find( _
                "[開始日] = '" & .Cells(r, 1) & " " & FormatDateTime(.Cells(r, 2), vbShortTime) & "' AND " & _
                "[終了日] = '" & .Cells(r, 1) & " " & FormatDateTime(.Cells(r, 3), vbShortTime) & "' AND " & _
                "[件名] = '" & .Cells(r, 4) & "' AND " & _
                "[場所] = '" & .Cells(r, 5) & "'")
            If Not objAppt Is Nothing Then
                If .Cells(r, 6) = "" Then ' 変更日付がなければ削除
                    ' 会議をキャンセル状態とする
                    objAppt.MeetingStatus = olMeetingCanceled
                    ' キャンセル通知を送信
                    objAppt.Send
                    ' キャンセルした会議を削除
                    objAppt.Delete
                Else    ' 変更日付があれば変更
                    objAppt.Start = .Cells(r, 6) & " " & FormatDateTime(.Cells(r, 7), vbShortTime)
                    objAppt.End = .Cells(r, 6) & " " & FormatDateTime(.Cells(r, 8), vbShortTime)
                    ' 変更通知を送信
                    objAppt.Send
                End If
            End If
            r = r + 1
        Wend
    End With
End Sub

メール本文のテキストのみをコピーするマクロ

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


初めての訪問です。ご相談があって書き込みをさせていただきます。
実は、Outlookで受信したメールの本文に含まれる「氏名」をコピペして、FileMakerで構築したDBを検索すると、以前はヒットしていたものが、2016以降、ヒットしなくなりました。
同じメールをGmailやWindows10のメールで受信して同じことをやると以前のようにヒットしますので、Outlook2016の問題ではないかと睨んでいます。
ところが、試しに本文中の「氏名」を件名にコピペして、さらにそれをコピペすると、FileMakerでの検索がヒットします。
つまり、ヒットしないのは、「本文中にある氏名」をコピペした場合のみです。
メール設定をいろいろと試してみましたし、「本文中にある氏名」をペーストする際にプレーンテキストとして貼り付けたりもしてみましたが、どうしてもうまくいきません。
日常業務に支障が出始めておりますが、今のところ原因・解決のめどがまったく立っておらず、こうして藁をもすがる思いで書き込みをさせていただきました。
もし、何かヒントでもございましたら、ぜひ、ご教示いただけないでしょうか。
よろしくお願いいたします。



一度件名にコピー&ペーストしてからさらにコピー&ペーストで発生しないとなると、Outlook の本文からのコピーの際にテキスト情報以外のものが含まれることで、検索に影響が発生している可能性が考えられます。
Windows でコピー&ペーストを行うと、内部的には以下のような動作が行われます。

  1. コピー元のアプリケーションからコピー先のアプリケーションに転送できるデータの形式を通知する
  2. コピー先のアプリケーションが取得できる最適な形式を指定してコピー元のアプリケーションからデータを受け取る

例えば、Outlook の HTML メールの本文をコピー&ペーストする場合、コピー先のアプリケーションにはデータ形式としてプレーン テキストと HTML テキストが通知されます。
そして、例えば受け取る側がメモ帳ならプレーン テキストが選択されて単なる文字列がコピーされ、Word なら HTML テキストが選択されて HTML タグを含んだ文字列がコピーされます。
おそらくは FileMaker がペーストした際にプレーン テキストではないデータを要求することで現象が発生しているのではないかと推測しますが、私の手元に FileMaker がないため、実際にそのような動作なのかはちょっと確認できません。

そこで、Outlook で選択した本文のプレーン テキストのみをコピーするというマクロを作ってみました。
このマクロを使用するには、まず以下の手順で Microsoft Forms 2.0 というライブラリを参照設定として追加します。

  1. Visual Basic Editor で [ツール]-[参照設定] をクリックします。
  2. [参照] をクリックします。
  3. 以下のいずれかの DLL を選択し、[開く] をクリックします。
    C:\Windows\System32\FM20.DLL
    C:\Windows\SysWOW64\FM20.DLL
  4. [OK] をクリックします。

そして、以下のマクロを定義し、本文のテキストのみをコピーしたいときにはこのマクロを実行します。
こちらで現象が回避できるか試してみてください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub CopyTextOnly()
    Dim dataObject As New MSForms.dataObject
    dataObject.SetText ActiveInspector.WordEditor.Application.Selection
    dataObject.PutInClipboard
End Sub

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

メールを読んだ際に自動的に返信するマクロ

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


お世話になります。
指定した相手から届いたメールを読んだ際にメールを読んだ事を相手に自動的に返信する様な機能をマクロで実現出来ないでしょうか?
バージョンはoutlook2016です。



このような処理を行う場合、以下の処理が必要になります。

  • メールを受信時に指定した相手からのメールであれば返信が必要という意味のカスタム プロパティを設定する。
  • メールを開いた際に、返信が必要というプロパティが設定されていれば自動的に返信する。

これを実装したマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Dim WithEvents mInspectors As Inspectors
'
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    On Error Resume Next
    Dim arrSender As Variant
    Dim oneSender As Variant
    Dim objMail 'As MailItem
    ' 返信が必要な差出人を , で区切って指定
    arrSender = Array("user1@example.com", "user2@example.com", "mchiba@jpoffolk.local")
    Set mInspectors = Application.Inspectors
    Set objMail = Session.GetItemFromID(EntryIDCollection)
    For Each oneSender In arrSender
        If objMail.SenderEmailAddress = oneSender Then
            ' 差出人が一致したらカスタム プロパティを設定
            Dim userProp As UserProperty
            Set userProp = objMail.UserProperties.Add("NeedReadReply", olText)
            userProp.Value = "Yes"
            objMail.Save
        End If
    Next
End Sub
'
Private Sub mInspectors_NewInspector(ByVal Inspector As Inspector)
    Dim objMail As MailItem
    Dim userProp As UserProperty
    Set objMail = Inspector.CurrentItem
    ' 開いたメールのカスタム プロパティを確認
    Set userProp = objMail.UserProperties.Find("NeedReadReply")
    If Not userProp Is Nothing Then
        ' 返信が必要なら開封済みのメッセージを送信
        If userProp.Value = "Yes" Then
            Dim objReply As MailItem
            Set objReply = objMail.Reply
            objReply.Body = "以下のメールを開封しました。" & vbCrLf & _
                "送信日時:" & objMail.SentOn & vbCrLf & "件名:" & objMail.Subject
            objReply.Send
            ' カスタム プロパティに返信済みと設定
            userProp.Value = "Done"
            objMail.Save
        End If
    End If
End Sub

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