ホーム
Office
Outlookのメールの保存を半自動化してみた¶

Outlookのメールの保存を半自動化してみた¶

Outlookで受信したメールをPCのローカルドライブに保存しているのですが、手作業で100通近く処理するととても面倒なので、マクロで自動化してみました。

試した環境は下記です。

Outlook 2013
Windows 8.1

保存の方針 ¶
コード ¶
試してみた ¶
まとめ ¶

保存の方針¶

「これは」というメールは、PCのローカルドライブに保存するようにしています。本文をPDF変換して添付ファイルもろともZipファイルにしていたのですが、件数が多くなると手間がばかになりません。というわけで、この作業を半自動化したいと思います。

メールをOutlook 2013からフォルダにドロップするとMSG形式のファイルとしてコピーされるので、最初はMSGファイルをC#でパースしようと考えました。MSDNにMSG形式の仕様書が公開されているのですが、ソフトウェア素人の私には解読不能でした。ということで、C#でのパースはあきらめて、OutlookのVisual Basic for Application (VBA)でいきたいと思います。

Outlookで受け取るメールはテキスト形式とHTML形式とRTF形式の3種類があるのですが、本文と書式（見た目）と添付ファイルが残っていれば良いので、MSG形式のファイルと本文をテキストに変換したファイルと添付ファイルをZIPファイルにまとめて保存するようにします。

また、ファイル名は下記にするようにしました。

[送信日][タグ（複数）][送信元アドレス]_タイトル.zip

コード¶

マクロは下記のようにしてみました。

#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If

Sub SaveAsZip()


    On Error GoTo errorEx

    Dim openedItem As Outlook.Inspector
    Dim targetItem As Object

    Set openedItem = Application.ActiveInspector
    If Not TypeName(openedItem) = "Nothing" Then
        ' メールのメタ情報を取得する
        Set targetItem = openedItem.CurrentItem

        Dim title As String
        title = targetItem.Subject
        title = Trim(title)
        title = Replace(title, "\", "_")
        title = Replace(title, "/", "_")
        title = Replace(title, "?", "_")
        title = Replace(title, ":", "_")
        title = Replace(title, "*", "_")
        title = Replace(title, """", "_")
        title = Replace(title, ">", "_")
        title = Replace(title, "<", "_")
        title = Replace(title, "|", "_")

        Dim senderAddress As String
        senderAddress = "[" & targetItem.SenderEmailAddress & "]"

        Dim sendDate As Date
        sendDate = targetItem.SentOn
        Dim sendDateString As String
        sendDateString = "[" & Format(sendDate, "YYYYMMDD HHNN") & "]"

        Dim mailCategolies As String
        mailCategories = targetItem.Categories
        mailCategory = Split(mailCategories, ",")
        mailCategories = ""
        Dim str As Variant
        For Each str In mailCategory
            mailCategories = mailCategories & "[" & Trim(str) & "]"
        Next str

        ' 保存するフォルダ名を設定する
        Dim pathName As String
        pathName = "c:\mail\"

        ' 保存するファイル名を設定する
        Dim filename As String
        filename = sendDateString & mailCategories & senderAddress & "_" & title
        filename = LeftB(filename, 220 - LenB(pathName))
        filename = Left(filename, Len(filename))

        ' ファイルアクセス用のオブジェクトの生成
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set app = CreateObject("Shell.Application")

        ' Zipファイル名を設定する
        Dim zipPath As String
        zipPath = pathName & filename & ".zip"
        If fso.FileExists(zipPath) = True Then
            fso.DeleteFile zipPath
        End If

        ' Zipファイルの生成
        With fso.CreateTextFile(zipPath, True)
            .Write "PK" & Chr(5) & Chr(6) & String(18, 0)
            .Close
        End With

        ' 圧縮フォルダのオブジェクトの生成
        Set zipFolder = app.NameSpace(fso.GetAbsolutePathName(zipPath))

        ' メール本文を保存して、圧縮フォルダに移動する
        Dim itemCount As Integer
        targetItem.SaveAs pathName & filename & ".txt", olTXT
        targetItem.SaveAs pathName & filename & ".msg", olMSG
        itemCount = zipFolder.Items().Count
        zipFolder.MoveHere (pathName & filename & ".txt")
        Do Until (itemCount < zipFolder.Items().Count)
            Sleep 100
        Loop
        itemCount = zipFolder.Items().Count
        zipFolder.MoveHere (pathName & filename & ".msg")
        Do Until (itemCount < zipFolder.Items().Count)
            Sleep 100
        Loop

        ' 添付ファイルを保存して、圧縮フォルダに移動する
        Dim attachedFiles As Attachments
        Set attachedFiles = targetItem.Attachments
        Dim filesName As String
        filesName = ""
        Dim I As Integer
        For I = 1 To targetItem.Attachments.Count
            itemCount = zipFolder.Items().Count
            targetItem.Attachments.Item(I).SaveAsFile pathName & targetItem.Attachments.Item(I).DisplayName
            zipFolder.MoveHere (pathName & targetItem.Attachments.Item(I).DisplayName)
            filesName = filesName & targetItem.Attachments.Item(I).DisplayName & "|"
            Do Until (itemCount < zipFolder.Items().Count)
                Sleep 100
            Loop
        Next
    Else
        MsgBox "メールを開いてからマクロを実行してください。"
    End If
    Exit Sub

errorEx:
    MsgBox "エラーが発生しました。"
End Sub

処理の流れはコメントに書いてある通りなのですが、ちょっと説明を書いておきます。

pathNameという変数に保存するフォルダのパスを設定します。メールを保存する場所応じて書き換え必要です。

その下のファイル名設定の箇所ですが、LeftB()とLeft()を使って文字列を短くしています。これは、ファイルシステムのパス名とファイル名の文字数制限に合わせるためのものです。ファイル名にメールのタイトルを使うのですが、メールのタイトルには1バイト文字と2バイト文字が混じります。すると、LeftB()でバイト単位で抜き出すと抜き出した文字列の最後が2バイト文字の最初の1バイトだけみたいな状態になることがあります。Len関数で文字数をカウントするとこの半分だけの文字は1文字とはカウントしないようなので、Left()にLen()の結果を指定して抜き出すことで、末尾に半分だけの文字がある場合はそれを削除します。

MoveHereの後ろにDoループがあります。これは、ファイルを保存する場合に生じる問題を回避するためのものです。MoveHereという関数が、前のファイルの圧縮が終わる前に次のファイルを圧縮しようとするようで、圧縮するファイルが複数あるとエラーになるのです。これを回避するために、ウェイトの目的でDoループを入れています。流れとしては、下記の感じです。

Zipファイルの中のファイル数を記録しておく。
MoveHereでファイルを圧縮フォルダに移動する命令を発行する。
Zipファイルの中のファイル数を調べて、記録しておいたファイル数と比較する。ファイル数が増えていたらループを抜ける。

「BASIC　→　インタープリタ　→　命令を順番に実行する」　と短絡的に考えていたので、てっきり必ず順々に命令が実行されるものと思っていました。

試してみた¶

早速試してみます。

下図の様なテストメールを準備しました。「Outlook」と「WordPress」という分類が付いていて、テキストファイルとExcelファイルが添付されています。

「開発」タブの「コード」のリボンの「マクロ」メニューから、マクロを実行します。そうすると、下図の様なZipファイルが生成されます。

Zipファイルの中には、下図の様にMSGファイルとテキストファイルと添付されていたファイルが入っています。

まとめ¶

上記のコードにはエラーが起きたときの処理が書いてありませんので、もし参考にされる場合は注意してください。特に上記のコードでは、既存のファイルを強制的に上書きします。例えば、同名のファイルが存在したら処理を止めるとか、ファイル名に秒単位の時刻を含めるとか、アレンジしてください。

久しぶりにVBっぽいプログラムを書いたら、ものすごい違和感が・・・。すっかりC#に慣れてしまったようです。それに、Visual StudioのIDEがとても素晴らしい物だということがよくわかりました。インテリセンスさんの居ない開発環境はつらい。

公開日 2016-04-08

Outlookのメールの保存を半自動化してみた¶

保存の方針¶

コード¶

試してみた¶

まとめ¶

Officeカテゴリの投稿

まことさんは考えた