メールExcel抽出ツール

最近、メール関連で問題となっていて、メール情報を消失していました。

・メールアドレスのパスワードが無効化していて、突然HDDアクセスできなくなる。(昨年)
・フリーメールの運用中止があり、バックアップが間に合わなかった。(一昨年)

現在、利用できるメールは、ファイル感覚で管理したいと思っていたが、
フリーメールを主に使うので、メール専用アプリは所有していなく、
身近にあるアプリは、ノートPC購入時にオマケのExcel2013・Word2013があるくらい。
これらで、メールのメンテナンスを手軽に行えないかと考えていました。

今年1月にWindows7サポート終了で、Windows10に切り替えたPCに、再インストールしたら、
Office2013扱いになったようで、Outlook2013とPowerPoint2013が追加していたのだ。

このアプリを使うようになり、ブラウザメールに比べ、高い機能を知ります。
・複数メールアドレスを登録するだけで同時に使用できる。
・メール情報は、Excelファイルに抽出できる。

Outlook本体だけでExportが可能でも、日時情報が欠落しているのです。
さらに、抽出領域の指定なので、フォルダ数分を繰り返す必要があるのです。
そこで、アドレス別にメールを全抽出するマクロを作ってみました。
Outlookの全フォルダを検索し、Excelシートに抽出するものです。

macro機能
入力：Outlook2013のメール
出力：Excel2013のシート

・1件以上フォルダにメールが存在すれば、抽出する
(個人が追加したフォルダも対象にする)
・メールアドレスをシート名として抽出メールを展開する
・抽出項目
メール件数、受信日時、題目、送信者名、送信元アドレス、本文(255文字まで)

Sub getMail()
    ' outlook関連の初期設定を行う
    Dim i As Long
    Dim outlookObj As Outlook.Application
    Dim inboxFolder As Outlook.folder
    Dim myNameSpace As Object
        Set outlookObj = CreateObject("Outlook.Application")
        Set myNameSpace = outlookObj.GetNamespace("MAPI")
        Set inboxFolder = myNameSpace.GetDefaultFolder(olFolderInbox) ' デフォルトの受信フォルダ
    ' Excel関連の初期設定を行う
    Dim n As Long
    Dim acc As Account
    Dim sheet As Worksheet

    For Each acc In inboxFolder.Session.Accounts
        n = 2 ' 2行目から展開
        Worksheets().Add After:=Worksheets(Worksheets.Count)   ' 末尾に追加
        Set sheet = ActiveSheet ' 現在アクティブなシートを取得する
        sheet.Name = acc
        ' Excelの先頭行に文字を設定する
        setSubject (sheet.Name)
        ' メールアドレス配下のoutlook情報を取得する
        Set inboxFolder = myNameSpace.folders(sheet.Name)
        ' メール情報のあるフォルダを検出する
        Call listSubFolders(inboxFolder, n, sheet.Name)
    Next
    ' 処理終了メッセージを表示する
    MsgBox "OutlookメールのExcel取得が完了しました。"
    ' 使用した変数を開放する
    Set outlookObj = Nothing
    Set myNameSpace = Nothing
    Set inboxFolder = Nothing
End Sub
Sub listSubFolders(ByVal folderOL As Outlook.folder, ByRef m As Long, ByRef nameSht As String)
    Dim fol As Outlook.folder
    For Each fol In folderOL.folders
        ' メール情報があれば、Excelに展開し、検索を続ける
        If fol.Items.Count > 0 Then
            ' Excelシートにメール情報を抽出する
            Call setCell(m, fol, nameSht)
            m = m + fol.Items.Count
            listSubFolders fol, m, nameSht
        End If
    Next
    Set fol = Nothing
End Sub
Sub setSubject(ByRef nameSht As String)
    With Sheets(nameSht)
        Range("A" & 1).Value = "件"
        Range("B" & 1).Value = "名前毎の件数"
        Range("C" & 1).Value = "受信日時"
        Range("D" & 1).Value = "題目"
        Range("E" & 1).Value = "送信者名"
        Range("F" & 1).Value = "送信元アドレス"
        Range("G" & 1).Value = "本文"
    End With
End Sub
Sub setCell(ByVal num As Integer, ByRef folder As Outlook.folder, ByRef nameSht As String)
    Dim i As Long
    Dim objItem As Object
    For i = 1 To folder.Items.Count
        Set objItem = folder.Items(i)
        With Sheets(nameSht)
            Range("A" & num).Value = num - 1
            Range("B" & num).Value = folder & "[" & CStr(i) & "]"
            Range("C" & num).Value = objItem.ReceivedTime
            Range("D" & num).Value = objItem.Subject
            Range("E" & num).Value = objItem.SenderName
            Range("F" & num).Value = objItem.SenderEmailAddress
            Range("G" & num).Value = Left(objItem.Body, 255)
        End With
        num = num + 1
    Next
    Set objItem = Nothing
End Sub

件数が多いとそれなりに時間かかるので、ご注意ください。