40歳からExcelに挑戦!

OutlookのメールをExcelに取り込む  色々なフォルダに対応





こんばんは。雪ん子です。
お越しいただきありがとうございます。

このブログはExcelやAccessの備忘録です。

初心者なので、変なコードとか出てくるかもしれません( ノД`)
もっと良い方法があったら、どしどしコメント下さいね。


以前の記事でサブフォルダのメールを取り込む方法を紹介しました。
OutlookのメールをExcelに取り込む サブフォルダ対応


この方法だと、メール取り込む場合、皆さんに同じ場所に同じ名前のフォルダを作ってもらわなければいけなくなります。

また、フォルダを変更したい場合はVBAをいじってフォルダ名を変更しないといけないんですよね。

しかし、我が部署にVBAいじれる人なんてほとんどいない!
その度に出動するのはちょっと面倒……。
なんとか対処せねば!



という事で。
またまた色々なサイトを参考にさせていただき、発展させたのが今回のもの。


「受信トレイに、この名前・・・・のサブフォルダを作ってね。」

「Excelに読み込む用のフォルダを作っておいてね。」


と、フォルダ名の指定をなくすことに成功しました!

また、念のためフォルダの階層が増えても大丈夫なように対応しておくことにしました。
例)Outlookの「私の名前のアカウント」内の、「受信トレイ親フォルダ」内の、「申込書子フォルダ」内の、「取り込み用孫フォルダ」から。

Outlookの指定フォルダのメールをExcelに取り込む

指定したフォルダのメールを一括で取り込みます。

私の設定

  • VBA画面のツール→参照設定

  Visual Basic For Applications
  Microsoft Excel 15.0 Object Library
  OLE Automation
  Microsoft Office 15.0 Object Library
 の4つにチェック。
 

  • シート名を「リスト」に。

 

  • 一行目に題名
A B C D E F
1 受信日時 差出人 差出人
アドレス
CC 件名 本文

 

  • 少し離れたところにフォルダ名の入力欄を作成
AA AB AC AD
1 アカウント名
※必須
親フォルダ名
※必須
子フォルダ名 孫フォルダ名
2 ×××@×××.jp 受信トレイ 申込書 取り込み用

VBA

Public Sub 受信メールサブフォルダ()

'画面更新停止
    Application.ScreenUpdating = False


' 定義
    Dim objOL As Object
    Dim sht As Worksheet
    Dim rowCnt As Long
    Dim objNAMESPC As Object
    
    Dim StrA As String
    Dim StrB As String
    Dim StrC As String
    Dim StrD As String

    
' 「Outlookから取得する」をobjOLと命名
    Set objOL = CreateObject("Outlook.Application")
    
' 読み込むシート(シート名取り込み)をshtと命名
    Set sht = Worksheets("リスト")  ' シート名

' A列一番下のセルをrowCntと命名
    rowCnt = Cells(Rows.Count, "A").End(xlUp).Row

' メールの場所をobjNAMESPCと命名
    Set objNAMESPC = objOL.GetNamespace("MAPI")
    
' 指定フォルダの名前の入っている場所
    StrA = Worksheets("リスト").Range("AA2").Value  ' アカウント名
    StrB = Worksheets("リスト").Range("AB2").Value  ' 親フォルダ名
    StrC = Worksheets("リスト").Range("AC2").Value ' 子フォルダ名
    StrD = Worksheets("リスト").Range("AD2").Value ' 孫フォルダ名
    
  
' Outlookの指定フォルダのメールを最終行の1行下に取得・件数分繰り返す

'分岐---------------------------------------------------

' A・子フォルダ名も孫フォルダ名も空欄なら親フォルダを読み込む
    If Range("AC2") = "" And Range("AD2") = "" Then
    
        For Each itms1 In objNAMESPC.Folders(StrA).Folders(StrB).Items
               
            sht.Cells(rowCnt + 1, 1).Value = itms1.ReceivedTime  ' A列・受信日時
            sht.Cells(rowCnt + 1, 2).Value = itms1.SenderName    ' B列・差出人
            sht.Cells(rowCnt + 1, 3).Value = itms1.SenderEmailAddress   ' C列・差出人アドレス
            sht.Cells(rowCnt + 1, 4).Value = itms1.CC           ' D列・CC
            sht.Cells(rowCnt + 1, 5).Value = itms1.Subject       ' E列・件名
            sht.Cells(rowCnt + 1, 6).Value = itms1.Body          ' F列・本文
            
            rowCnt = Cells(Rows.Count, "A").End(xlUp).Row
        
        Next
        
    
' B・孫フォルダ名が空欄なら子フォルダを読み込む
    ElseIf Range("AD2") = "" Then
    
        For Each itms1 In objNAMESPC.Folders(StrA).Folders(StrB).Folders(StrC).Items
               
            sht.Cells(rowCnt + 1, 1).Value = itms1.ReceivedTime  ' A列・受信日時
            sht.Cells(rowCnt + 1, 2).Value = itms1.SenderName    ' B列・差出人
            sht.Cells(rowCnt + 1, 3).Value = itms1.SenderEmailAddress   ' C列・差出人アドレス
            sht.Cells(rowCnt + 1, 4).Value = itms1.CC           ' D列・CC
            sht.Cells(rowCnt + 1, 5).Value = itms1.Subject       ' E列・件名
            sht.Cells(rowCnt + 1, 6).Value = itms1.Body          ' F列・本文
            
            rowCnt = Cells(Rows.Count, "A").End(xlUp).Row
        
        Next
    
    
' C・孫フォルダを読み込む
    Else

        For Each itms1 In objNAMESPC.Folders(StrA).Folders(StrB).Folders(StrC).Folders(StrD).Items
               
            sht.Cells(rowCnt + 1, 1).Value = itms1.ReceivedTime  ' A列・受信日時
            sht.Cells(rowCnt + 1, 2).Value = itms1.SenderName    ' B列・差出人
            sht.Cells(rowCnt + 1, 3).Value = itms1.SenderEmailAddress   ' C列・差出人アドレス
            sht.Cells(rowCnt + 1, 4).Value = itms1.CC           ' D列・CC
            sht.Cells(rowCnt + 1, 5).Value = itms1.Subject       ' E列・件名
            sht.Cells(rowCnt + 1, 6).Value = itms1.Body          ' F列・本文
            
            rowCnt = Cells(Rows.Count, "A").End(xlUp).Row
        
        Next
        
    End If
'------------------------------------分岐ここまで

' セットしていた条件を解除
    Set objOL = Nothing
    Set sht = Nothing
    Set objNAMESPC = Nothing

    Range("A1").Select

' 画面更新停止を解除
    Application.ScreenUpdating = True

' 終了メッセージ
    MsgBox "終了しました。"
    
End Sub

※シート名・アカウント名・フォルダ名は各自設定しているものに変更してください。
※親フォルダは受信トレイ以外でも取り込めます。


これで、一行目の題名の下に指定したフォルダ内のメールがすべて取り込まれます。