スポンサーリンク

【Outlook-VBA】メールの受信時に添付ファイルを保存する

Outlook

こんにちは。blueです。

今回はOutlook VBAのイベントマクロを使った添付ファイル取得マクロについて説明します。

この記事を読むと

  1. メール受信時に自動的に添付ファイルを取得する
  2. 添付ファイルを送信者ごとにフォルダ分けする

ことができるようになります。

注意点として今回のマクロは導入後は受信時に自動的に発動するようになります。使用については自己責任でお願いします。

以下注意点です。

今回のイベントマクロ(NewMailEx)はMicrosft Exchangeを使用している場合はOutlookを起動している間しか機能しません。Outlookを閉じている間に受信したメールについては処理されないので注意ください。

内容については以下の記事が参考になります。

(なおMicrosoft Exchangeを使用しているかの確認はOutlookメニューバーの「ファイル」タブで確認できます。以下であればMicrosft Exchangeです)

②フォルダ作成時に使用する送信者名はOutlookのSenderNameプロパティから取得します。

しかしこの文字列に禁則文字(/や\など)が含まれているとフォルダ作成ができずエラーになります。

このエラーが出た場合はLike演算子, Instr関数, Replace関数などを使用して消去してやるとよいです。
禁則文字の処理マクロについては以下の記事を参考ください。




Outlook VBAでメール業務を効率化したい人にはこちらの書籍がお勧めです。

返信メールの下書きや日報作成など、煩雑な作業が一瞬でできるようになります。

またオブジェクト構造などの説明もあるので、慣れればOutlook上で行うほぼすべての作業を自動化させることができます。

スポンサーリンク

はじめに

イベントマクロとは何かの操作を行ったときに実行される処理のことです。

イベントマクロは各オブジェクトの変化を起点として色々な処理をさせることができます。

なおOutlook VBAの代表的なイベントマクロは[Microsoft Outlook Object]の[ThisOutlookSession]に用意されています。

具体的には以下のプロジェクトウィンドウ内の[ThisOutlookSession]をクリックしたところになります。

この中のオブジェクトボックスが対象オブジェクト、プロシージャボックスが具体的なイベントとなります。

クリックすると拡大します

今回はオブジェクトボックスからApplication、プロシージャボックスからNewMailExを選択します。

選択すると以下のコードが自動で表示されます。

クリックすると拡大します

なお最初から備わっているイベントマクロの場合イベント名や引数は自動で表示されます。自分で記載する必要はありません。

ちなみに選択時に自動的にItemSendなどのイベントが表示される場合があります。今回は不要ですので削除しておいてください。

今後はこのプロシージャ内に記載していきます。標準モジュールに記載しても動きませんので注意してください。

今回のフロー

今回のフローは以下になります。

  1. 事前に添付ファイルを保存するフォルダを指定する
  2. メールを受け取ったらIDからメールの内容を取得する
  3. 受け取ったメールについて添付ファイルの有無を確認する
  4. 存在する場合は送信者名のフォルダの存在可否を判断し、無ければ作成する
  5. 送信者名のフォルダに添付ファイルを保存する

線を引いたところがOutlook VBAならではのコードです。

以降で詳しく説明していきます。

全コード

上記のフローに対するコードは以下になります。途中にある”保存するフォルダ名”は自由に入れてください。なお再度となりますが使用の際は自己責任でお願いします。

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

    Dim EntryIDs As Variant
    Dim objId As Object
    Dim myNamespace As NameSpace
    Dim myFolder As String
    Dim strFileName As String
    Dim SenderName As String
    Dim SenderNameFolder As String
    Dim i As Long, j As Long
        

    myFolder = "保存するフォルダパス”
    
    EntryIDs = Split(EntryIDCollection, ",")
    Set myNamespace = GetNamespace("MAPI")
    
    For i = 0 To UBound(EntryIDs)
      Set objId = myNamespace.GetItemFromID(EntryIDs(i))
      If objId.Attachments.Count <> 0 Then
          If InStr(objId.SenderName, "@") > 0 Then
            SenderName = Left(objId.SenderName, InStr(objId.SenderEmailAddress, "@") - 1) '送信者のファイル名
          Else
            SenderName = objId.SenderName
          End If
        SenderNameFolder = myFolder & "\" & SenderName  '送信者のフォルダ名
          
        If Dir(SenderNameFolder, vbDirectory) = "" Then '送信者のフォルダ名存在可否判断
          MkDir (SenderNameFolder)
        End If
      
        For j = 1 To objId.Attachments.Count
          strFileName = objId.Attachments.Item(j).FileName
          objId.Attachments.Item(j).SaveAsFile SenderNameFolder & "\" & strFileName  '送信者のフォルダにファイルを保存
        Next j
      End If
    Next i
Stop
End Sub

各コードの説明

事前に添付ファイルを保存するフォルダを指定する

事前に保存するフォルダを作成し、添付ファイルを保存するフォルダパスをmyFolderとします。

このフォルダの下に各送信者の名前を持つフォルダを作成します。

メールを受け取ったらIDからメールを取得する

NewMailExイベントではイベント発動時にEntryIdCollectionが取得できます。

ただし複数メールを同時受信した場合 [,]で区切られるようです。

(2021/10/13未検証:複数にわかれたものを取得できていません)

その為一応Split関数でIDを分けます。EntryIDsのデータ型はVariantになることに注意ください。

またOutlookに関するデータ一式はGetNameSpaceメソッドで取得できるのでセットしておきます。引数はMAPI一択になります。

NameSpaceオブジェクトの説明についてはこちら

EntryIDs = Split(EntryIDCollection, ",")
Set myNamespace = GetNamespace("MAPI")

今後このEntryIDsに対して情報を取得していくことになります。

受け取ったメールについて添付ファイルの有無を確認する

受け取ったメールオブジェクト(objID)の中身をオブジェクトブラウザで見てみると以下のようになっています(実際に見る際は途中にStopを入れたり、ブレークポイントを作成するなどしてデバッグ状態になるようにしておいてください)。

クリックすると拡大します

ID情報からメールデータを取得することでEntry IDやSubject, SenderNameやCC, BCCなどの情報を取得できていることがわかります。

またこのメールオブジェクト内にAttachmentsも存在しており、その中にCountプロパティが存在していることがわかります。

以下ではSplit関数で取得したEntryIDsの一つ一つに対してobjID.AttachementsのCountが0でないときに以降の処理を実行させています。

For i = 0 To UBound(EntryIDs)
      Set objId = myNamespace.GetItemFromID(EntryIDs(i)) 
If objId.Attachments.Count <> 0 Then

存在する場合は送信者名のフォルダの存在可否を判断し、無ければ作成する

添付ファイルが存在する場合に送信者のメールアドレスから送信者情報を取得します。

ここではメールアドレスの@より前の情報を抜き出してSenderNameとしています。

(2021/10/13補足:Exchangeの場合サーバーに登録されたアドレスは”特定の表示名”で表示されメールアドレスでは表示されません。その為ここでは@がある場合とない場合で条件分岐させています)

さらに最初のmyFolderと結合して送信者フォルダ名(SenderNameFolder)としています。

If InStr(objId.SenderName, "@") > 0 Then
            SenderName = Left(objId.SenderName, InStr(objId.SenderEmailAddress, "@") - 1)
          Else
            SenderName = objId.SenderName

次にその送信者フォルダが存在するかをDir関数で確認し、存在しない場合はMkDirで新しいフォルダを作成しています。

  If Dir(SenderNameFolder, vbDirectory) = "" Then '送信者のフォルダ名存在可否判断
            MkDir (SenderNameFolder)
        End If

Dir関数は引数に指定したファイルが存在するかを確認する関数ですが第2引数としてvbDirectoryを指定することでフォルダの存在を確認できます。

送信者名のフォルダに添付ファイルを保存する

最後にフォルダに添付ファイルを保存します。

添付ファイルは先のCount分存在する為その回数分処理します。

For j = 1 To objId.Attachments.Count
            strFileName = objId.Attachments.Item(j).FileName
            objId.Attachments.Item(j).SaveAsFile SenderNameFolder & "\" & strFileName  '送信者のフォルダにファイルを保存
Next j

先ほども述べましたがAttachementsの中身は以下のようになっています。ファイル名はFileNameで取得できます。

クリックすると拡大します

この添付ファイルを所定のフォルダに保存するメソッドはSaveAsFileメソッドです。「添付ファイルのアイテム.SaveAsFile 保存先」で指定することで保存が可能です。

なおSaveAsFileメソッドの場合ファイル名が同じ場合は上書き保存されてしまいます。

私の業務では同名の古いファイルは必要ない為気にしていませんが、気にされる方はDir関数で再度ファイルを検索し、同じファイルが存在する場合は枝番を付けるなどの処理をしてください。

ここでのまとめ

Outlook VBAの代表的なイベントマクロは[Microsoft Outlook Object]の[ThisOutlookSession]に用意されています。

今回はメールを受信した際に起こすイベントとしてApplicationオブジェクトのNewMailExイベントを使用しました。

このイベントで取得したEntryIDをもとにすれば添付ファイルの保存だけでなく自動振り分けなども可能になりますので使用してみてください。

Outlook VBAでメール業務を効率化したい人にはこちらの書籍がお勧めです。

返信メールの下書きや日報作成など、煩雑な作業が一瞬でできるようになります。

またオブジェクト構造などの説明もあるので、慣れればOutlook上で行うほぼすべての作業を自動化させることができます。

コメント

  1. colour より:

    コメント失礼致します。
    とても便利なマクロなので利用させて頂きたいのですが、上書き保存されないようにすることは可能でしょうか?

    • blue blue より:

      すみません、遅れました。そんなに難しくはないので見てみます。

      • blue blue より:

        ・ファイル名の最初に日時を付けてよいなら以下が一番楽です。同日以外は上書き保存されません
        objId.Attachments.Item(j).SaveAsFile SenderNameFolder & “\” & Format(Date,”yyyymmdd”) & “_” & strFileName
        ・ファイル名が同じかどうかを調べるにはDir関数を使って
        If Dir(SenderNameFolder & “\” & strFileName)<>“” Then
        で調べます。ただ必ずファイル名を変えたいならDateなどの揮発関数を使ったほうが楽です。

  2. colour より:

    ご返信ありがとうございます。
    先頭に日付を付けると、ファイル名でソートした時に見辛くなってしまいました。
    ファイル名が同じかどうか調べて、同じの場合は末尾に数字を追加、さらに同じ場合は連番でカウントアップとか出来るでしょうか。
    同じファイル名で、更新されていくのですが、変更履歴を残さないといけないのです。

    • blue blue より:

      1 ソートで問題が生じるならFormat(Date,”yyyymmdd”)をファイル名の後にもっていけばいいと思います。ただこの場合拡張子と分けないといけないのでそこは以下のページを参考にしてください。
      http://officetanaka.net/excel/vba/tips/tips78.htm
      https://excel-ubara.com/excelvba4/EXCEL275.html
      2 枝番を付ける場合については普通のフォルダで確認しました(同じ環境がもうないので)。
      以下を参考にしてもらえれば添付ファイルでも枝番付きのものが生成されていくと思います。

      Sub test()

      Dim BaseName As String ‘ファイル名の拡張子抜き
      Dim BaseNameReName As String ‘リネームしたもの
      Dim i As Long

      BaseName = “210101”

      ‘もしBaseNameが存在しない場合はそのまま保存する
      If Dir(“フォルダパス” & BaseName & “.xlsm”) = “” Then
      ThisWorkbook.SaveAs FileName:=”フォルダパス” & BaseName & “.xlsm”
      Exit Sub
      ‘もしBaseNameが存在する場合は_ver iを付ける
      Else
      i = 0
      BaseNameReName = BaseName & “_ver” & i
      ‘BaseNameReNameが存在しなくなるまで続ける。存在しなくなったらBaseNameReNameで保存する
      Do Until Dir(“フォルダパス” & BaseNameReName & “.xlsm”) = “”
      i = i + 1
      BaseNameReName = BaseName & “ver” & i
      Loop
      ThisWorkbook.SaveAs FileName:=”フォルダパス” & BaseNameReName & “.xlsm”
      End If

      End Sub

  3. colour より:

    ご返信ありがとうございます。
    とても参考になりました。
    VBA初心者ですが、業務効率化の為に今後も精進させて頂きます。
    引き続きブログ参考させて頂きます。

    • blue blue より:

      ありがとうございます。パソコンを開いている環境でないと取得できないのが残念ですが活用してもらえたなら幸いです。
      引き続きよろしくお願いします^^

タイトルとURLをコピーしました