Outlookメール文書直接読み出し　味はソコソコ？Excel Tips（しお味）

メール文書接読み出し

ここでは、outlookの文書を直接読み出して、より汎用性のあるものにして有効活用するためのツールになります。 Outlookは優れたツールですが、えてして、機能がいろいろありすぎて少しもてあますところがあります。（その意味ではoutlook　expressの方が使いやすかった）また特定の形式のメールを様々に加工したり、検索したりする場合もoutlook側から、何らかの処理をしてexcel等に渡す事になり 2度手間にもなりかねません。そこで、今回は直接excelにoutlookの文書を読み込んで、そのまま様々な処理に繋げる事ができるようなツールを作ってみました。

●vbaでoutlookを操作するには・・・
まず、vbaの編集ツールである VBE(Visual Basic Edtor)のメニューで、
「ツール」->「参照設定」と進み
[Microsoft Outlook 16.0 object Library]※
[Microsoft Forms 2.0 object Library]※
[Microsoft Windows Common Contorols 6.0(sp6)※
にチェックを入れてOKボタンを押します。

参照設定	ライブラリー選択

(※数字の部分はexcelのバージョンにより変わります)

●outlookのメール文書直接読み出し

outlookのメール文書の読み出し情報としては以下のものがあります

・宛先情報（メールアドレス　TO：、CC：）
・発信元情報（メールアドレス、名前情報）
・メール表題
・本文の内容
・添付ファイル情報（ファイル名、ファイル数）

このようなメール情報を直接excel側に取り込む事によって、例えば決まったフォーマットを日々受信してなにか処理を進める場合にあらかじめ処理するものをexcel側で用意しておくことにより、その処理の工数時間の大幅な低減がはかれる場合があります。

outlook文書直接読み出し

設定画面	読み出し文書

このツールは、Outlookの受信メール情報とカレンダー情報をexcelに直接読み込みます。
また読み込んだメール文書のキーワード検索も出来ます。
outlook文書直接読み出し（メイン）

  'Outlookのメール文書の取得**************************************************************************

  Option Explicit

  Sub Outlook_mail_list()

    Application.StatusBar = False


     '/////////////////////////////////////////////変数の宣言
      Dim sht As Worksheet
      Dim InboxFolder, i, n, k, attno As Long
      Dim sender, mes, path1 As String
      Dim outlookObj As Outlook.Application
      Dim myNameSpace, objmailItem As Object
      Dim strt As Long
      Dim endc As Long
      Dim FSO As Object
      Dim getnmb As Long

      Set FSO = CreateObject("Scripting.FileSystemObject")

      getnmb = Worksheets("MAINS").Cells(7, 6)

      Worksheets("DSPER").Cells.Clear

      '////////////////////////////////////////////変数に必要な項目をセット
      Set outlookObj = CreateObject("Outlook.Application")
      Set myNameSpace = outlookObj.GetNamespace("MAPI")
      Set InboxFolder = myNameSpace.GetDefaultFolder(6)
      n = 2


      '////////////////////////////////////////////メールの添付ファイルを保管するフォルダを作成
      path1 = Worksheets("MAINS").Cells(6, 6)
      'path1 = ThisWorkbook.Path & "\" & mes
      Set FSO = CreateObject("Scripting.FileSystemObject")
      'FSO.CreateFolder (path1)

      '///////////////////////////////////////////解析する受信メールの範囲を決める

      MsgBox "総データ数:" & InboxFolder.Items.Count & "  取得データ数:" & getnmb & vbNewLine & "OutLook文書を抽出します。"

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

      ' プログレスバーFormを表示
      UserForm1.Show vbModeless
      'プログレスバーの最小値を設定
      UserForm1.ProgressBar1.Min = 0
      'プログレスバーの最大値を設定
      UserForm1.ProgressBar1.Max = 100 ' Count
      'プログレスバーの現在値を設定
      'UserForm1.ProgressBar1.value =


      Worksheets("DSPER").Select
      Set sht = Worksheets("DSPER")

      ' シートクリア、文字列セット
      With sht
          .Cells.Clear
          '.Cells(1, 1).Value = "連番"
          .Cells(1, 1).Value = "受信日時"
          .Cells(1, 2).Value = "表題"
          .Cells(1, 3).Value = "差出人"
          .Cells(1, 4).Value = "CC"
          .Cells(1, 5).Value = "本文"
          .Cells(1, 6).Value = "添付数"
          .Cells(1, 7).Value = "添付ファイル名"
      End With

      endc = InboxFolder.Items.Count

      strt = InboxFolder.Items.Count - getnmb + 1

      On Error Resume Next

    '////////////////////////////////////////////////////////////////////////////////////

   For i = strt To endc

          Set objmailItem = InboxFolder.Items(i)

      '//////////////////受信メールの件数、受信日時、件名(タイトル)、送信者名、送信元のメールアドレス、内容(本文)を取得
     'Cells(n, 1) = i
      Cells(n, 1) = objmailItem.ReceivedTime
      Cells(n, 2) = objmailItem.Subject
      Cells(n, 3) = objmailItem.SenderName
      Cells(n, 4) = objmailItem.SenderEmailAddress
      Cells(n, 5) = Left(objmailItem.Body, 100)


      'Sheets("DSPER").Range("A:A").ColumnWidth = 6
      Sheets("DSPER").Range("A:A").ColumnWidth = 15
      Sheets("DSPER").Range("B:B").ColumnWidth = 30
      Sheets("DSPER").Range("C:C").ColumnWidth = 30
      Sheets("DSPER").Range("D:D").ColumnWidth = 15
      Sheets("DSPER").Range("E:E").ColumnWidth = 40
      Sheets("DSPER").Range("F:F").ColumnWidth = 7
      Sheets("DSPER").Range("G:G").ColumnWidth = 14

      Sheets("DSPER").Rows.RowHeight = 20

      Sheets("DSPER").Activate

      '/////////////////メール本文の書式

      Range("E:E").Select
      With Selection
          .HorizontalAlignment = xlLeft
          .VerticalAlignment = xlTop
          .WrapText = True
          .Orientation = 0
          .AddIndent = False
          .IndentLevel = 0
          .ShrinkToFit = False
          .ReadingOrder = xlContext
          .MergeCells = False
      End With

     '/////////////////////////////////////////////////////////////メールの添付ファイルを保管する

          attno = objmailItem.Attachments.Count      '添付ファイルのカウンター

          If attno > 0 Then

              For k = 1 To attno

                    '添付ファイルの取得
                    If Worksheets("MAINS").CheckBox1.Value = True Then

                        objmailItem.Attachments(k).SaveAsFile (path1 & "\" & objmailItem.Attachments(k).DisplayName)

                        Worksheets("DSPER").Cells(n, 7) = objmailItem.Attachments(k).DisplayName

                        Else

                        Worksheets("DSPER").Cells(n, 7) = objmailItem.Attachments(k).DisplayName

                    End If

              Next

              Cells(n, 6).Value = k

          Else

              Cells(n, 6).Value = "なし"

          End If



          n = n + 1


        UserForm1.ProgressBar1.Value = 100 * (n - 2) / getnmb
        UserForm1.Label1.Caption = "現在 " & (n - 2) & "件" & Format(100 * (n - 2) / getnmb, " ###") & "％進行中"

   Next  '/////////////////////////////////////////////////////////////////////////////////////////////////////////////////

      Columns("A:A").Select
      ActiveWorkbook.Worksheets("DSPER").Sort.SortFields.Clear
      ActiveWorkbook.Worksheets("DSPER").Sort.SortFields.Add Key:=Range("A1"), _
          SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
      With ActiveWorkbook.Worksheets("DSPER").Sort
          .SetRange Range("A2:G10000")
          .Header = xlNo
          .MatchCase = False
          .Orientation = xlTopToBottom
          .SortMethod = xlPinYin
          .Apply
      End With

      Worksheets("DSPER").Activate
      Worksheets("DSPER").Cells(1, 1).Select


      '////////////////////////////////////////////////////////////セットした変数の後処理
      Set outlookObj = Nothing
      Set myNameSpace = Nothing
      Set InboxFolder = Nothing


      Worksheets("MAINS").Select

      Unload UserForm1

      Application.ScreenUpdating = True      '画面の更新の再開


      MsgBox "データの取得完了しました"


      Worksheets("DSPER").Activate
      Worksheets("DSPER").Cells(1, 1).Select


  End Sub

outlookのカレンダー情報読み出し

  'Outlookカレンダー情報の取得***********************************************************************

  Sub getOutlookCalenderItems()

      Dim startc As Date               '集計開始日
      Dim endc As Date                 '集計終了日
      Dim drow As Integer
      Dim apcount As Long
      Dim lngRowCount As Long         '読み出しデータ数
      Dim objSheet As Object           'オブジェクト変数割り当て

      startc = Worksheets("MAINS").Cells(6, 2)
      endc = Worksheets("MAINS").Cells(7, 2)

      Worksheets("DSPER").Cells.Clear

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

      ' Outlookオブジェクト
      Dim objOLApp ' As Outlook.Application
      Set objOLApp = CreateObject("Outlook.Application")

      ' Outlook名前空間
      Dim nmsOLApp ' Outlook.NameSpace
      Set nmsOLApp = objOLApp.GetNamespace("MAPI")

      ' 予定表フォルダー
      Dim fldCalendar ' Outlook.Folder
      Set fldCalendar = nmsOLApp.GetDefaultFolder(olFolderCalendar)
      'Set fldCalendar = nmsOLApp.GetDefaultFolder(olFolderInbox)

      ' 予定
      Dim colAppts ' As Items
      Set colAppts = fldCalendar.Items
      colAppts.Sort "[Start]"
      colAppts.IncludeRecurrences = True

      ' 個々の予定
      Dim objAppt  As AppointmentItem
      'Set objAppt = colAppts.Find("[Start] < ""2019/7/1"" AND [End] >= ""2018/1/1""")

      '読み出し日の範囲の設定
      Set objAppt = colAppts.Find("[Start] < """ & endc & """ AND [End] >= """ & startc & """")

      apcount = fldCalendar.Items.Count

      Worksheets("MAINS").Cells(11, 2) = fldCalendar.Items.Count

      MsgBox "OutLookのカレンダー情報を抽出します"

     'プログレスバーFormを表示
     UserForm1.Show vbModeless
     'プログレスバーの最小値を設定
     UserForm1.ProgressBar1.Min = 0
     'プログレスバーの最大値を設定
     UserForm1.ProgressBar1.Max = 1000 ' Count
     'プログレスバーの現在値を設定
     'UserForm1.ProgressBar1.value =

      Set objSheet = ThisWorkbook.Sheets(2)

      Sheets("DSPER").Range("A:C").ColumnWidth = 10
      Sheets("DSPER").Range("D:D").ColumnWidth = 40
      Sheets("DSPER").Range("E:E").ColumnWidth = 15
      Sheets("DSPER").Range("F:F").ColumnWidth = 50

      Sheets("DSPER").Rows.RowHeight = 20

      Sheets("DSPER").Activate

      Range("F:F").Select
      With Selection
          .HorizontalAlignment = xlLeft
          .VerticalAlignment = xlTop
          .WrapText = True
          .Orientation = 0
          .AddIndent = False
          .IndentLevel = 0
          .ShrinkToFit = False
          .ReadingOrder = xlContext
          .MergeCells = False
      End With

      With objSheet    '/////////////////////////////////////////////////////////////////////////////////////////////////

          .Cells(1, 1).Value = "開始日"
          .Cells(1, 2).Value = "開始時刻"
          .Cells(1, 3).Value = "終了時刻"
          .Cells(1, 4).Value = "件名"
          .Cells(1, 5).Value = "場所"
          .Cells(1, 6).Value = "内容"
          lngRowCount = 2

          While Not objAppt Is Nothing      '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
              .Cells(lngRowCount, 1).Value = FormatDateTime(objAppt.Start, vbShortDate)
              .Cells(lngRowCount, 2).Value = FormatDateTime(objAppt.Start, vbShortTime)
              .Cells(lngRowCount, 3).Value = FormatDateTime(objAppt.End, vbShortTime)
              .Cells(lngRowCount, 4).Value = objAppt.Subject
              .Cells(lngRowCount, 5).Value = objAppt.Location
              .Cells(lngRowCount, 6).Value = objAppt.Body

              ' 次のアイテム
              Set objAppt = colAppts.FindNext
              lngRowCount = lngRowCount + 1

              UserForm1.ProgressBar1.Value = 100 * lngRowCount / apcount
              UserForm1.Label1.Caption = "現在 " & lngRowCount & "件" & Format(100 * lngRowCount / apcount, " ###") & "％進行中"

          Wend    '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<


      End With    '///////////////////////////////////////////////////////////////////////////////////////////////////////

      '受信日による降順ソート

      Columns("A:A").Select
      ActiveWorkbook.Worksheets("DSPER").Sort.SortFields.Clear
      ActiveWorkbook.Worksheets("DSPER").Sort.SortFields.Add Key:=Range("A1"), _
          SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
      With ActiveWorkbook.Worksheets("DSPER").Sort
          .SetRange Range("A2:G10000")
          .Header = xlNo
          .MatchCase = False
          .Orientation = xlTopToBottom
          .SortMethod = xlPinYin
          .Apply
      End With

      Set objMsg = Nothing
      Set objFSO = Nothing

      Set objAppt = Nothing
      Set colAppts = Nothing
      Set fldCalendar = Nothing
      Set nmsOLApp = Nothing
      Set objOLApp = Nothing

      Sheets("DSPER").Cells(1, 1).Select

      Worksheets("MAINS").Select

      drow = Worksheets("DSPER").Cells(Rows.Count, 1).End(xlUp).Row

      Unload UserForm1

      Application.ScreenUpdating = True      '画面の更新の再開

      MsgBox "データの取得完了しました （データ数：" & drow & "件）"

      Worksheets("DSPER").Activate

      Worksheets("DSPER").Cells(1, 1).Select

  End Sub

outlookのメール文書のキーワード検索

  '読み取り情報の検索********************************************************************************************

  Sub chrserch()

  Dim schr As String
  Dim drow As Long
  Dim pcount As Integer
  Dim ncount As Integer

  drow = Worksheets("DSPER").Cells(Rows.Count, 1).End(xlUp).Row
  schr = Worksheets("MAINS").Cells(13, 2)


  Worksheets("DSPER").Cells.ClearFormats


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


     For k = 1 To drow          '/////////////////////////////////////////////////////////////////////////////////////////////////////////////////

         If InStr(Worksheets("DSPER").Cells(k, 2), schr) <> 0 Then               '2列目検索

                Worksheets("DSPER").Cells(k, 2).Interior.Color = RGB(255, 253, 155)

                pcount = pcount + 1
                ncount = ncount + 1

                Else

                'Worksheets("DSPER").Rows(k).Hidden = True

         End If


         If InStr(Worksheets("DSPER").Cells(k, 3), schr) <> 0 Then               '3列目検索


                Worksheets("DSPER").Cells(k, 3).Interior.Color = RGB(255, 253, 155)

                pcount = pcount + 1
                ncount = ncount + 1

                Else

                'Worksheets("DSPER").Rows(k).Hidden = True

         End If


         If InStr(Worksheets("DSPER").Cells(k, 4), schr) <> 0 Then                 '4列目検索

                Worksheets("DSPER").Cells(k, 4).Interior.Color = RGB(255, 253, 155)

                pcount = pcount + 1
                ncount = ncount + 1

                Else

                'Worksheets("DSPER").Rows(k).Hidden = True

         End If


         If InStr(Worksheets("DSPER").Cells(k, 5), schr) <> 0 Then                 '5列目検索

                Worksheets("DSPER").Cells(k, 5).Interior.Color = RGB(255, 253, 155)

                pcount = pcount + 1
                ncount = ncount + 1

                Else

               ' Worksheets("DSPER").Rows(k).Hidden = True

         End If


        If InStr(Worksheets("DSPER").Cells(k, 6), schr) <> 0 Then


                Worksheets("DSPER").Cells(k, 6).Interior.Color = RGB(255, 253, 155)

                pcount = pcount + 1
                ncount = ncount + 1

                Worksheets("DSPER").Rows(k).Hidden = False

                Else

               ' Worksheets("DSPER").Rows(k).Hidden = True

         End If



       If pcount = 0 And k > 1 Then  '検索無関係行の非表示

             Worksheets("DSPER").Rows(k).Hidden = True

             'Worksheets("DSPER").Cells(k, 7) = pcount

             pcount = 0

             Else

             pcount = 0

       End If


     Next        '///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

       Sheets("DSPER").Activate

      Range("F:F").Select
      With Selection
          .HorizontalAlignment = xlLeft
          .VerticalAlignment = xlTop
          .WrapText = True
          .Orientation = 0
          .AddIndent = False
          .IndentLevel = 0
          .ShrinkToFit = False
          .ReadingOrder = xlContext
          .MergeCells = False
      End With


      If Worksheets("DSPER").Cells(1, 1) = "開始日" Then  'カレンダー用のフォーマット

         Range("A:A").NumberFormatLocal = "yyyy/m/d"
         Range("B:B").NumberFormatLocal = "hh:mm"
         Range("C:C").NumberFormatLocal = "hh:mm"
         Range("A:C").ColumnWidth = 10
         Range("D:D").ColumnWidth = 40
         Range("E:E").ColumnWidth = 15
         Range("F:F").ColumnWidth = 50

         Else

         Range("A:A").NumberFormatLocal = "yyyy/m/d hh:mm"  'メール文書用のフォーマット

         Range("A:A").ColumnWidth = 15
         Range("B:B").ColumnWidth = 30
         Range("C:C").ColumnWidth = 30
         Range("D:D").ColumnWidth = 15
         Range("E:E").ColumnWidth = 40
         Range("F:F").ColumnWidth = 7
         Range("G:G").ColumnWidth = 14

      End If

      Worksheets("MAINS").Select

      Application.ScreenUpdating = True     '画面の更新の再開

      Worksheets("MAINS").Cells(13, 5) = ncount

      MsgBox "検索を完了しました"

      Worksheets("DSPER").Activate
      Worksheets("DSPER").Cells(1, 1).Select

  End Sub

outlookメール文書の直接読み出し

outlookメール文書の直接読み出し
outlookメール文書の直接読み出しツール
上のものと同じものです。

outlookメール文書の直接読み出し　ダウンロード