Outlookの受信メールを受信日が最新のものから取得する

経緯・趣旨

Outlookの受信トレイやサブフォルダから、最新のメールを数件取得したい。
ただ、標準VBOのMS Outlook Email VBOのGet Received Itemsアクションを使って取ろうとすると、古いメールから取得されてしまい、コレクションを圧迫してしまう。何とか効率よく取得したい。

方法

MS Outlook Email VBOを拡張。
Internal_Get Itemsを複製＆一部修正し、受信メール取得というアクションを作る。

アクション全体

Internal_Get ItemsのInputにデータアイテムReceivedTime Order, Get Row Countを追加。
ReceivedTime Orderはフラグ型のデータアイテムで、Trueにすると受信日の降順、Falseもしくはブランクで昇順でメールを取得する。
Get Row Countは数値型のデータアイテムで、取得したいメール件数を設定する。

開始ステージ

コードステージ

入力

ReceivedTime Order, Get Row Countを追加

出力

Internal_Get Itemsから変更なし

コード

Internal_Get Itemsのコードの最後に数行追加。
VB.NETでOutlookの操作をしたことがなかったので、ネットで調べながら見様見真似で書いてみました^^;

Dim PR_SMTP_ADDRESS As String = "https://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Dim app = CreateObject("Outlook.Application")
Dim _nameSpace As Microsoft.Office.Interop.Outlook.NameSpace = app.GetNameSpace("MAPI")

Dim folder As Folder
Item_Count = 0

If Not String.IsNullOrEmpty(Shared_Mailbox) Then
	Dim recipient = _nameSpace.CreateRecipient(Shared_Mailbox)
    recipient.Resolve()
	If recipient.Resolved Then
		folder = _nameSpace.GetSharedDefaultFolder(recipient, Outlook_Folder_ID)
	Else
		Dim ex1 As New System.Exception(VbCrlf + "Failed to resolve shared mailbox '" + Shared_Mailbox + "'.")
		Throw ex1
	End If
Else
	If Not String.IsNullOrEmpty(Account_Display_Name) Then
		Try
			Dim aa As List(Of Account) = _nameSpace.Accounts.Cast(Of Account).ToList()
			folder  = aa.Where(Function(x) x.DisplayName = Account_Display_Name).FirstOrDefault().DeliveryStore.GetDefaultFolder(Outlook_Folder_ID)
		Catch ex As System.Exception
			Dim ex1 As New System.Exception(VbCrlf + "Failed to retrieve default folder for Account Display Name '" + Account_Display_Name + "'." + VbCrlf + ex.Message)
			Throw ex1
		End Try
	Else
		folder = _nameSpace.GetDefaultFolder(Outlook_Folder_ID)
	End If
End If

If Sub_Folder <> "" Then
	For each name as string in Sub_Folder.Split("\")
		folder = folder.Folders(name)
	Next
End If

'See https://msdn.microsoft.com/en-us/library/office/aa210946(v=office.11).aspx
'for mail item properties
Dim dataTable As New Data.DataTable
dataTable.Columns.Add("EntryID", Type.GetType("System.String"))
dataTable.Columns.Add("To", Type.GetType("System.String"))
dataTable.Columns.Add("CC", Type.GetType("System.String"))
dataTable.Columns.Add("Subject", Type.GetType("System.String"))
dataTable.Columns.Add("Body", Type.GetType("System.String"))
dataTable.Columns.Add("Attachments", Type.GetType("System.String"))
dataTable.Columns.Add("ReceivedOn", Type.GetType("System.DateTime"))
dataTable.Columns.Add("SentOn", Type.GetType("System.DateTime"))
dataTable.Columns.Add("SenderName", Type.GetType("System.String"))
dataTable.Columns.Add("SenderEmailAddress", Type.GetType("System.String"))
dataTable.Columns.Add("Unread", Type.GetType("System.Boolean"))
dataTable.Columns.Add("Sensitivity", Type.GetType("System.Int16"))
dataTable.Columns.Add("Importance", Type.GetType("System.Int16"))
dataTable.Columns.Add("Flag", Type.GetType("System.String"))
dataTable.Columns.Add("IsHTML", Type.GetType("System.Boolean"))

Dim folderItems = If(Filter_Expression <> "", folder.Items.Restrict(Filter_Expression), folder.Items)

For Each item As Object In folderItems

	If Not TypeOf item Is MailItem Then Continue For
	Dim row As Data.DataRow = dataTable.NewRow
	row("EntryID") = item.EntryID
	row("To") = item.To
	row("CC") = item.CC
	row("Subject") = item.Subject
	row("Body") = If(item.BodyFormat = 2, item.HTMLBody, item.Body)
	
	Dim attachments As String = ""
	For Each attachment As Object In item.Attachments
        If attachment.Type = 1 Then
			attachments = attachments & "|" & attachment.DisplayName
		End If
	Next
	
	row("Attachments") = If (attachments.Length = 0, "", attachments.SubString(1))
	row("SentOn") = item.SentOn
	row("ReceivedOn") = item.ReceivedTime
	row("SenderName") = item.SenderName

	If item.SenderEmailType = "EX" Then
		Dim sender As AddressEntry = item.Sender
		If sender IsNot Nothing Then
			If sender.AddressEntryUserType = OlAddressEntryUserType.olExchangeUserAddressEntry OrElse sender.AddressEntryUserType = OlAddressEntryUserType.olExchangeRemoteUserAddressEntry Then
				Dim exchUser As ExchangeUser = sender.GetExchangeUser()
				If exchUser IsNot Nothing Then
					row("SenderEmailAddress") = exchUser.PrimarySmtpAddress
				End If
			ElseIf sender.AddressEntryUserType = OlAddressEntryUserType.olExchangeDistributionListAddressEntry Then
				Dim exchDL As ExchangeDistributionList = sender.GetExchangeDistributionList
				If exchDL IsNot Nothing Then
					row("SenderEmailAddress") = exchDL.PrimarySmtpAddress
				End If
			Else
				row("SenderEmailAddress") = TryCast(sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS), String)
			End If
		End If
	Else
		row("SenderEmailAddress") = item.SenderEmailAddress
	End If

	row("Unread") = item.Unread
	row("Sensitivity") = item.Sensitivity
	row("Importance") = item.Importance
	row("Flag") = item.FlagRequest
	row("IsHTML") = (item.BodyFormat = 2)

	dataTable.Rows.Add(row)
Next

' ここから追加 ===================================================
Dim rowcnt As Long = 0
Dim dtblSrt As New Data.DataTable()
Dim whereStr As String = ""

If ReceivedTime_Order Then
	whereStr = "ReceivedOn DESC"
End If

Dim rows As Data.DataRow() = dataTable.Select(Nothing, whereStr)
dtblSrt = dataTable.Clone()

For Each row As Data.DataRow In rows
	If Item_Count <= Get_Row_Count - 1 OR Get_Row_Count = 0 Then
		dtblSrt.ImportRow(row)
		Item_Count += 1
	End If
Next

Items = dtblSrt

終了ステージ

Internal_Get Itemsから変更なし

実行結果

ReceivedTime OrderをTrue, Get Row Countを10に設定

10件の受信メールが、受信日の降順に取得できていることが確認できました。