コメントにて以下のご要望をいただきました。
お世話になります。
毎日の仕事の振り返りのヒントとして、Outlookから発信したメール､開催通知等(以後メール等と表記)を記録に残しておきたいと思っています。
以前は「ジャーナル」機能があったのでそれを使っていたのですが、現在では自動的に記録する機能がありません。
そこで、メール等がSentOnになったらExcelのファイルに追記していくOutlookVBAマクロを作ってみました。
———————–8<———————–8<———————–
Option Explicit
Dim WithEvents mySentItems As Items ‘ ItemAdd イベントをハンドルするオブジェクト
‘ Outlook 起動時に実行されるイベント
Private Sub Application_Startup()
Set mySentItems = Session.GetDefaultFolder(olFolderSentMail).Items ‘ 送信済みアイテム フォルダーへのアイテム追加をハンドルするためのオブジェクト設定
End Sub
‘ 送信済みアイテムに移ってきたメッセージの情報をExcelファイルに追記する処理
Private Sub mySentItems_ItemAdd(ByVal Item As Object)
Dim excelApp As Object ‘ Excelオブジェクトの作成
Set excelApp = CreateObject(“Excel.Application”)
Dim workbook As Object ‘ Excelファイルを開く
Set workbook = excelApp.Workbooks.Open(“C:Users********送信ﾛｸﾞ.xlsx”)
Dim sheet As Object ‘ 追記するシートを選択
Set sheet = workbook.Sheets(“送信ﾛｸﾞ”)
Dim lastRow As Long lastRow = sheet.Cells(sheet.Rows.Count, 1).End(-4162).Row ‘ 最終行を取得 ‘ データを追記
sheet.Cells(lastRow + 1, 1).Value = Format(Item.SentOn, “yyyy/mm/dd hh:mm:ss”)
sheet.Cells(lastRow + 1, 2).Value = Item.To
sheet.Cells(lastRow + 1, 3).Value = Item.subject
workbook.Save ‘ Excelファイルを保存
workbook.Close ‘ Excelファイルを閉じる
Set sheet = Nothing ‘ Excelオブジェクトを解放
Set workbook = Nothing
Set excelApp = Nothing
End Sub
———————–8<———————–8<———————–
上記のマクロはメールを送信したときは問題なく機能しますが、会議開催通知などの場合は
Item.To
のところでエラーになります。
(送信済フォルダに入ってくるのはメールだけとは限らないからだと思いますが)
送信したメール等はすべて記録しておきたいので、どのように修正すればよいでしょうか。
よろしくご教授ください
To プロパティと Cc プロパティについては、MailItem オブジェクトでのみ使用できるものです。
そのため、会議出席依頼に相当する MeetingItem オブジェクトでこれらのプロパティを取得しようとするとエラーとなります。
To や Cc をサポートしないオブジェクトでも、Recipients プロパティからあて先情報が取得できるので、これをもとに To や Cc の文字列を生成することでご要望は満たせるでしょう。
以下の関数は引数 objItem で指定されたメールなどのアイテムから lType で指定された種類の受信者すべての表示名を取得するものです。
Private Function GetToCc(ByVal objItem As Object, lType As Long)
Dim strNames As String
Dim objRec As Recipient
strNames = ""
For Each objRec In objItem.Recipients
If objRec.Type = lType Then
strNames = strNames & objRec.Name & "; "
End If
Next
' 余計な最後の ; を削除
If strNames <> "" Then
strNames = Left(strNames, Len(strNames) - 2)
End If
GetToCc = strNames
End Function
例えば、
sheet.Cells(lastRow + 1, 2).Value = Item.To
としている個所を、
sheet.Cells(lastRow + 1, 2).Value = GetToCc(Item, olTo)
のようにすることで、メール以外のアイテムでもエラーを発生させることなくあて先情報が取得できます。
Outlook 研究所 