受信した Excel ファイルを印刷するマクロ

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


outlook2010で2つのメールアドレスを使用しています。その片方のメールアドレスに届いたエクセルファイルだけ自動で印刷するということをしたいです。

このようなマクロを作成していただけないでしょうか?



2 つのメールアドレスを使用するというのが、以下のどちらのことを意味しているのかがちょっと分かりかねましたので、ルールで実行するマクロにしました。

  • 一つのアカウントに複数のメールアドレスが受信される
  • 二つのアカウントでそれぞれに受信される

以下のようなマクロを定義し、「受信者のアドレスに特定の文字が含まれる場合」や「指定されたアカウントを経由した場合」の条件で実行されるルールのアクションの「スクリプトを実行する」のスクリプトとして、PrintExcelAttach を指定してください。

' ここをトリプルクリックでマクロ全体を選択できます。
' 以下はソースの先頭に記載する必要があります。
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
                (ByVal hwnd As Long, ByVal lpszOp As String, _
                 ByVal lpszFile As String, ByVal lpszParams As String, _
                 ByVal LpszDir As String, ByVal FsShowCmd As Long) _
                 As Long
'
Public Sub PrintExcelAttach(ByRef objItem As MailItem)
    On Error Resume Next
    Const ATTACH_PATH = "c:\temp\" ' 添付ファイルを保存するフォルダー
    Dim objAttach As Attachment
    Dim strFileName As String
    Dim c As Integer
    ' 添付ファイルの印刷
    Dim objFSO 'As FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objAttach In objItem.Attachments
        If objAttach.FileName Like "*.xls*" Then
            ' ファイルが Excel の場合のみ保存して印刷
            c = 1
            With objAttach
                strFileName = .FileName
                While objFSO.FileExists(ATTACH_PATH & strFileName)
                    strFileName = Left(.FileName, InStrRev(.FileName, ".") - 1) _
                        & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                    c = c + 1
                Wend
                .SaveAsFile ATTACH_PATH & strFileName
            End With
            '    保存したファイルを印刷する
            ShellExecute 0, "print", ATTACH_PATH & strFileName, 0, ATTACH_PATH, 0
        End If
    Next
End Sub

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

仕訳ルールでメールの本文と PDF のみ印刷するマクロ

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


毎回、こちらのサイトにとてもお世話になっております。どうしてもお力添えいただきたく質問させていただきました。
・ 仕様環境 Win10(32bit) OUTLOOK2010
マクロは使用せず、仕分けルールと印刷設定を利用しまして、メールを受信したら添付ファイルごと自動で全て印刷をしております。
この際、【メール本文+PDF】は印刷したいのですが、それ以外の添付ファイル(doc、docx、xls、xlsx、ppt、pptx、zip、csv、exe 等)は印刷しないで無視するように設定できないものか苦慮しております。
このような都合の良いマクロを作りたいと考えているのですが、何か良い方法はございますでしょうか。



ルールの指定では特定の種類のファイルだけ印刷しないというようなことはできないので、本文の印刷と添付ファイルが pdf のときだけ保存して印刷をするというマクロを作成し、それをルールの条件として呼び出すことでご要望の動作ができると思います。
以下のマクロを設定し、ルールの条件で [スクリプト] としてマクロの名前を指定してください。

' ここをトリプルクリックでマクロ全体を選択できます。
' 以下はソースの先頭に記載する必要があります。
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
                (ByVal hwnd As Long, ByVal lpszOp As String, _
                 ByVal lpszFile As String, ByVal lpszParams As String, _
                 ByVal LpszDir As String, ByVal FsShowCmd As Long) _
                 As Long
'
Public Sub PrintBodyAndPDFAttach(ByRef objItem As MailItem)
    On Error Resume Next
    Const ATTACH_PATH = "c:\temp\" ' 添付ファイルを保存するフォルダー
    Dim objAttach As Attachment
    Dim strFileName As String
    Dim c As Integer
    ' 本文を印刷
    objItem.PrintOut
    ' 添付ファイルの印刷
    Dim objFSO 'As FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objAttach In objItem.Attachments
        If objAttach.FileName Like "*.pdf" Then
            ' ファイルが PDF の場合のみ保存して印刷
            c = 1
            With objAttach
                strFileName = .FileName
                While objFSO.FileExists(ATTACH_PATH & strFileName)
                    strFileName = Left(.FileName, InStrRev(.FileName, ".") - 1) _
                        & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                    c = c + 1
                Wend
                .SaveAsFile ATTACH_PATH & strFileName
            End With
            '    保存したファイルを印刷する
            ShellExecute 0, "print", ATTACH_PATH & strFileName, 0, ATTACH_PATH, 0
        End If
    Next
End Sub

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

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

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


お世話になっております。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