40歳からExcelに挑戦!

OutlookのメールをExcelに取り込む  サブフォルダ対応





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

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

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


実は、前回紹介したモノではメインの受信ボックスしか取り込めないんですよね(^_^;)


Outlookのメールを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 件名 本文

VBA

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

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

' 定義
Dim objOL As Object
Dim sht As Worksheet
Dim rowCnt As Long
Dim objNAMESPC As Object

' 「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")

' Outlookの指定フォルダのメールを最終行の1行下に取得・件数分繰り返す
For Each itms1 In objNAMESPC.Folders("アカウント名").Folders("受信トレイ").Folders("フォルダ名").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

Set objOL = Nothing

Range("A1").Select

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

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

End Sub


※シート名・アカウント名・フォルダ名は各自設定しているものに変更してください。


アドセンスを自動挿入にしているので、文中に広告が出てしまっていたら申し訳ありませんm(_ _)m