ACCESS VBA OutLookのメールをテーブルに記録するマクロを改造する（1） How to make Mail Property access table
の続き
ACCESS2013 Later で確認しているが、おそらくそれ以前でも動くでしょう
##GeocitiesのVBAを次のように改造する。
1.''<<の行は実際に動かすとエラーが出て値が入らないためコメントアウトで無効化した。
2.値要求でエラーが出るところは、フィールドを値要求なしにする一方でNullという文字を入れた。
3.OUTLOOK VBA 選択したメールのフォルダのメールのリストを作る Make MailItem List of selected Mail Folder
前回作成したOutlookからEXCELファイルを作るVBAマクロの場合はOUTLOOK上でフォルダを選択してから作成しているが、とりあえず今回は受信フォルダ決め打ちである。したがって複数のメールアドレスをOUTLOOKで扱うときの挙動はよくわからない。
4.とりあえず Set RequestsFolder = myNaSp.GetDefaultFolder(olFolderInbox)
この行でわかるように今回のVBAでは受信フォルダのリストを作っている。
5.作成するテーブルの名前はtest2である。Geoはtestだったので。
##作成上で気付いたFORの挙動
For と For EACHではFor Eachが最後までリストを作成できない
For i = myItems.Count To 1 Step -1
ここのところを当初はFor each myitem in Myitemsにしていたが、メールによっては途中で止まってしまう。
どうも全アイテム数からバックしないと正確なデータが出ない。
なのでFor EACHは使うことができない。
またGeocitiesは本文などほとんど丸ごと取ろうとしているが、これは無理があるので、EXCELと同じように制限をしている。
###おぼえがき
1.テーブルの作成のパターン
db.createtabledef
tdf.fld.append tdf.createfield
db.TableDefs.Append tdf Application.RefreshDatabaseWindow
とすると画面に表示される
2.そのあとに値要求、空文字列を設定する。
3.リッチテキスト形式設定のため関数を引用している。
4.フィールドの長さは100にしているので適宜調節。
##VBAソース
###テーブル作成VBAマクロ
まずAccessの新規データベースを作ります。MACROを許可してください。
次に下のMaketableListを起動し、テーブル（test2)を作成します。
maketbltest
Sub maketbltest()
Dim db As Database: Set db = CurrentDb
Dim tdf As TableDef, fld As Field
Dim prp As Property
Dim i As Long
On Error Resume Next
DoCmd.DeleteObject acTable, "test2"
On Error GoTo 0
Set tdf = db.CreateTableDef("test2")
Set fld = tdf.CreateField("Actions", dbText, 100)
tdf.Fields.Append fld
tdf.Fields.Append tdf.CreateField("AlternateRecipientAllowed", dbText, 100)
tdf.Fields.Append tdf.CreateField("Application", dbText, 100)
tdf.Fields.Append tdf.CreateField("Attachments", dbText, 100)
tdf.Fields.Append tdf.CreateField("AutoForwarded", dbText, 100)
tdf.Fields.Append tdf.CreateField("AutoResolvedWinner", dbText, 100)
tdf.Fields.Append tdf.CreateField("BCC", dbText, 100)
tdf.Fields.Append tdf.CreateField("BillingInformation", dbText, 100)
tdf.Fields.Append tdf.CreateField("Body", dbText, 100)
tdf.Fields.Append tdf.CreateField("BodyFormat", dbText, 100)
tdf.Fields.Append tdf.CreateField("Categories", dbText, 100)
tdf.Fields.Append tdf.CreateField("CC", dbText, 100)
tdf.Fields.Append tdf.CreateField("Class", dbText, 100)
tdf.Fields.Append tdf.CreateField("Companies", dbText, 100)
tdf.Fields.Append tdf.CreateField("Conflicts", dbText, 100)
tdf.Fields.Append tdf.CreateField("ConversationID", dbText, 100)
tdf.Fields.Append tdf.CreateField("ConversationIndex", dbText, 100)
tdf.Fields.Append tdf.CreateField("ConversationTopic", dbText, 100)
tdf.Fields.Append tdf.CreateField("CreationTime", dbDate, 100)
tdf.Fields.Append tdf.CreateField("DeferredDeliveryTime", dbDate, 100)
tdf.Fields.Append tdf.CreateField("DeleteAfterSubmit", dbText, 100)
tdf.Fields.Append tdf.CreateField("DownloadState", dbText, 100)
tdf.Fields.Append tdf.CreateField("EntryID", dbText, 100)
tdf.Fields.Append tdf.CreateField("ExpiryTime", dbDate, 100)
tdf.Fields.Append tdf.CreateField("FlagRequest", dbText, 100)
tdf.Fields.Append tdf.CreateField("FormDescription", dbText, 100)
tdf.Fields.Append tdf.CreateField("GetInspector", dbText, 100)
tdf.Fields.Append tdf.CreateField("HTMLBody", dbText, 100)
tdf.Fields.Append tdf.CreateField("Importance", dbText, 100)
tdf.Fields.Append tdf.CreateField("InternetCodepage", dbText, 100)
tdf.Fields.Append tdf.CreateField("IsConflict", dbText, 100)
tdf.Fields.Append tdf.CreateField("IsMarked As Task", dbText, 100)
tdf.Fields.Append tdf.CreateField("ItemProperties", dbText, 100)
tdf.Fields.Append tdf.CreateField("LastModificationTime", dbDate, 100)
tdf.Fields.Append tdf.CreateField("Links", dbText, 100)
tdf.Fields.Append tdf.CreateField("MarkForDownload", dbText, 100)
tdf.Fields.Append tdf.CreateField("MessageClass", dbText, 100)
tdf.Fields.Append tdf.CreateField("Mileage", dbText, 100)
tdf.Fields.Append tdf.CreateField("NoAging", dbText, 100)
tdf.Fields.Append tdf.CreateField("OriginatorDeliveryReportRquested", dbText, 100)
tdf.Fields.Append tdf.CreateField("OutlookInternalVersion", dbText, 100)
tdf.Fields.Append tdf.CreateField("OutlookVersion", dbText, 100)
tdf.Fields.Append tdf.CreateField("Parent", dbText, 100)
tdf.Fields.Append tdf.CreateField("Permission", dbText, 100)
tdf.Fields.Append tdf.CreateField("PermissionService", dbText, 100)
tdf.Fields.Append tdf.CreateField("PermissionTemplateGuid", dbText, 100)
tdf.Fields.Append tdf.CreateField("PropertyAccessor", dbText, 100)
tdf.Fields.Append tdf.CreateField("ReadReceiptRequested", dbText, 100)
tdf.Fields.Append tdf.CreateField("ReceivedByEntryID", dbText, 100)
tdf.Fields.Append tdf.CreateField("ReceivedByName", dbText, 100)
tdf.Fields.Append tdf.CreateField("ReceivedOnBehalfOfEntryID", dbText, 100)
tdf.Fields.Append tdf.CreateField("ReceivedOnBehalfOfName", dbText, 100)
tdf.Fields.Append tdf.CreateField("ReceivedTime", dbDate, 100)
tdf.Fields.Append tdf.CreateField("RecipientReassignmentProhbited", dbText, 100)
tdf.Fields.Append tdf.CreateField("Recipients", dbText, 100)
tdf.Fields.Append tdf.CreateField("ReminderOverrideDefault", dbText, 100)
tdf.Fields.Append tdf.CreateField("ReminderPlaySound", dbText, 100)
tdf.Fields.Append tdf.CreateField("Reminder Set ", dbText, 100)
tdf.Fields.Append tdf.CreateField("ReminderSoundFile", dbText, 100)
tdf.Fields.Append tdf.CreateField("ReminderTime", dbDate, 100)
tdf.Fields.Append tdf.CreateField("RemoteStatus", dbText, 100)
tdf.Fields.Append tdf.CreateField("ReplyRecipientNames", dbText, 100)
tdf.Fields.Append tdf.CreateField("ReplyRecipients", dbText, 100)
tdf.Fields.Append tdf.CreateField("RetentionExpirationDate", dbText, 100)
tdf.Fields.Append tdf.CreateField("RetentionPolicyName", dbText, 100)
Set fld = tdf.CreateField("RTFBody", dbMemo, 100)
tdf.Fields.Append fld: Set fld = Nothing
tdf.Fields.Append tdf.CreateField("Saved", dbText, 100)
tdf.Fields.Append tdf.CreateField("SaveSentMessageFolder", dbText, 100)
tdf.Fields.Append tdf.CreateField("Sender", dbText, 100)
tdf.Fields.Append tdf.CreateField("SenderEmailAddress", dbText, 200)
tdf.Fields.Append tdf.CreateField("SenderEmailType", dbText, 100)
tdf.Fields.Append tdf.CreateField("SenderName", dbText, 100)
tdf.Fields.Append tdf.CreateField("SendUsingAccount", dbText, 100)
tdf.Fields.Append tdf.CreateField("Sensitivity", dbText, 100)
tdf.Fields.Append tdf.CreateField("Sent", dbText, 100)
tdf.Fields.Append tdf.CreateField("SentOn", dbDate, 100)
tdf.Fields.Append tdf.CreateField("SentOnBehalfOfName", dbText, 100)
tdf.Fields.Append tdf.CreateField("Session", dbText, 100)
tdf.Fields.Append tdf.CreateField("Size", dbText, 100)
tdf.Fields.Append tdf.CreateField("Subject", dbText, 100)
tdf.Fields.Append tdf.CreateField("Submitted", dbText, 100)
tdf.Fields.Append tdf.CreateField("TaskCompletedDate", dbText, 100)
tdf.Fields.Append tdf.CreateField("TaskDueDate", dbText, 100)
tdf.Fields.Append tdf.CreateField("TaskStartDate", dbText, 100)
tdf.Fields.Append tdf.CreateField("TaskSubject", dbText, 100)
tdf.Fields.Append tdf.CreateField("To", dbText, 200)
tdf.Fields.Append tdf.CreateField("ToDoTaskOrdinal", dbText, 100)
tdf.Fields.Append tdf.CreateField("UnRead", dbBoolean, 100)
tdf.Fields.Append tdf.CreateField("UserProperties", dbText, 100)
tdf.Fields.Append tdf.CreateField("VotingOptions", dbText, 100)
tdf.Fields.Append tdf.CreateField("VotingResponse", dbText, 100)
db.TableDefs.Append tdf
Application.RefreshDatabaseWindow
‘値要求をオフ、空文字””を許可 Required AllowZerolength
Set fld = tdf.Fields("RTFBody")
Call SetDAOProperty(fld, "TextFormat", dbByte, 1)
For i = tdf.Fields.Count - 1 To 0 Step -1
Set fld = tdf.Fields(i)
If fld.Attributes = 0 And fld.Type = dbText Then
fld.AllowZeroLength = True < ---空文字の許可
fld.Required = False < ---値要求
End If
Next i
End Sub
###Outlookのメールフォルダをリスト化するVBAマクロ
テーブル test2 を作ったら、Outlookで自分が作りたいフォルダを開きます。
たとえば保存先の受信トレイなどです。
次にACCESSで次のマクロを実行します。
最初の2行は一番上の方(Declare部)にコピペしてください。
MakeOlMailList.BAS
Dim tmp As Variant
Dim TName As String
Sub MakeOlMailList()
'Microsoft Outlook 11.0 Object Library
Dim db As Database: Set db = CurrentDb
Dim rs As Recordset
Dim myNaSp As Namespace
Dim myFolder As MAPIFolder
Dim mySecFolder As MAPIFolder
Dim myThrFolder As MAPIFolder
Dim FolderName As String
Dim myItem As MailItem
Dim myItems As Items
Dim GetTime As Date '読み取り日時を入れる場合
Dim myindex As Long
Dim RequestsFolder As Folder
Dim x As Long
Dim y As Long
Dim i As Long
Dim rc As Long
Dim Cnt As Long
'コレクションのプロパティはエラーになる
'On Error Resume Next
TName = "test2"
Set db = CurrentDb()
Set rs = db.OpenRecordset("test2", dbOpenDynaset)
Set myNaSp = GetNamespace("MAPI")
Set RequestsFolder = myNaSp.GetDefaultFolder(olFolderInbox)
Set myItems = RequestsFolder.Items
'For i = RequestsFolder.Items.Count To 1 Step -1
Debug.Print myItems.Count
Cnt = 1
If myItems.Count = 0 Then GoTo ERR_Handle
For i = myItems.Count To 1 Step -1
Set myItem = RequestsFolder.Items.Item(i) '受信メールの取得
On Error Resume Next
Cnt = Cnt + 1
Debug.Print Cnt, myItem.Subject, myItem.ReceivedTime
rs.AddNew
'rs.Fields("Actions").Value = myItem.Actions ''<<
rs.Fields("AlternateRecipientAllowed").Value = myItem.AlternateRecipientAllowed
rs.Fields("Application").Value = myItem.Application
'rs.Fields("Attachments").Value = myItem.Attachments ''<<
rs.Fields("AutoForwarded").Value = myItem.AutoForwarded
rs.Fields("AutoResolvedWinner").Value = myItem.AutoResolvedWinner
If Len(myItem.BCC) = 0 Then rs.Fields("BCC").Value = "Null" Else rs.Fields("BCC").Value = myItem.BCC
If Len(myItem.BillingInformation) = 0 Then rs.Fields("BillingInformation").Value = "Null" Else rs.Fields("BillingInformation").Value = myItem.BillingInformation
rs.Fields("Body").Value = Left(replacetext(myItem.Body), 100)
rs.Fields("BodyFormat").Value = myItem.BodyFormat
If myItem.Categories = "" Then rs.Fields("Categories").Value = "Null" Else rs.Fields("Categories").Value = myItem.Categories
If myItem.CC = "" Then rs.Fields("CC").Value = "Null" Else rs.Fields("CC").Value = Left(myItem.CC, 100)
rs.Fields("Class").Value = myItem.Class
If myItem.Categories = "" Then rs.Fields("Companies").Value = "Null" Else rs.Fields("Companies").Value = myItem.Companies
'rs.Fields("Conflicts").Value = myItem.Conflicts ''<<
rs.Fields("ConversationID").Value = myItem.ConversationID
rs.Fields("ConversationIndex").Value = myItem.ConversationIndex
If myItem.ConversationTopic = "" Then rs.Fields("ConversationTopic").Value = "Null" Else rs.Fields("ConversationTopic").Value = myItem.ConversationTopic
rs.Fields("CreationTime").Value = myItem.CreationTime
rs.Fields("DeferredDeliveryTime").Value = myItem.DeferredDeliveryTime
rs.Fields("DeleteAfterSubmit").Value = myItem.DeleteAfterSubmit
rs.Fields("DownloadState").Value = myItem.DownloadState
rs.Fields("EntryID").Value = Left(myItem.EntryID, 100) '''''
rs.Fields("ExpiryTime").Value = myItem.ExpiryTime
If myItem.FlagRequest = "" Then rs.Fields("FlagRequest").Value = "Null" Else rs.Fields("FlagRequest").Value = myItem.FlagRequest
If myItem.FormDescription = "" Then rs.Fields("FormDescription").Value = "Null" Else rs.Fields("FormDescription").Value = myItem.FormDescription
'rs.Fields("GetInspector").Value = myItem.GetInspector '<<
rs.Fields("HTMLBody").Value = Left(myItem.HTMLBody, 100)
rs.Fields("Importance").Value = myItem.Importance
rs.Fields("InternetCodepage").Value = myItem.InternetCodepage
rs.Fields("IsConflict").Value = myItem.IsConflict
rs.Fields("IsMarked As Task").Value = myItem.IsMarkedAsTask
rs.Fields("ItemProperties").Value = myItem.ItemProperties '<<
rs.Fields("LastModificationTime").Value = myItem.LastModificationTime
rs.Fields("Links").Value = myItem.Links
rs.Fields("MarkForDownload").Value = myItem.MarkForDownload
rs.Fields("MessageClass").Value = myItem.MessageClass
If myItem.Mileage = "" Then rs.Fields("Mileage").Value = "Null" Else rs.Fields("Mileage").Value = myItem.Mileage
rs.Fields("NoAging").Value = myItem.NoAging
rs.Fields("OriginatorDeliveryReportRquested").Value = myItem.OriginatorDeliveryReportRquested '<<
rs.Fields("OutlookInternalVersion").Value = myItem.OutlookInternalVersion
If myItem.OutlookVersion = "" Then rs.Fields("OutlookVersion").Value = "Null" Else rs.Fields("OutlookVersion").Value = myItem.OutlookVersion
rs.Fields("Parent").Value = myItem.Parent
rs.Fields("Permission").Value = myItem.Permission
rs.Fields("PermissionService").Value = myItem.PermissionService
'rs.Fields("PermissionTemplateGuid").Value = myItem.PermissionTemplateGuid '<<
rs.Fields("PropertyAccessor").Value = myItem.PropertyAccessor
rs.Fields("ReadReceiptRequested").Value = myItem.ReadReceiptRequested
rs.Fields("ReceivedByEntryID").Value = myItem.ReceivedByEntryID
rs.Fields("ReceivedByName").Value = myItem.ReceivedByName
rs.Fields("ReceivedOnBehalfOfEntryID").Value = myItem.ReceivedOnBehalfOfEntryID
rs.Fields("ReceivedOnBehalfOfName").Value = myItem.ReceivedOnBehalfOfName
rs.Fields("ReceivedTime").Value = myItem.ReceivedTime
'rs.Fields("RecipientReassignmentProhbited").Value = myItem.RecipientReassignmentProhbited '<<
rs.Fields("Recipients").Value = myItem.Recipients.Count
rs.Fields("ReminderOverrideDefault").Value = myItem.ReminderOverrideDefault
rs.Fields("ReminderPlaySound").Value = myItem.ReminderPlaySound
rs.Fields("Reminder Set ").Value = myItem.ReminderSet
If myItem.ReminderSoundFile = "" Then rs.Fields("ReminderSoundFile").Value = "Null" Else rs.Fields("ReminderSoundFile").Value = myItem.ReminderSoundFile
rs.Fields("ReminderTime").Value = myItem.ReminderTime
rs.Fields("RemoteStatus").Value = myItem.RemoteStatus
If myItem.ReplyRecipientNames = "" Then rs.Fields("ReplyRecipientNames").Value = "Null" Else rs.Fields("ReplyRecipientNames").Value = myItem.ReplyRecipientNames
rs.Fields("ReplyRecipients").Value = myItem.ReplyRecipients.Count
rs.Fields("RetentionExpirationDate").Value = myItem.RetentionExpirationDate
If myItem.RetentionPolicyName = "" Then rs.Fields("RetentionPolicyName").Value = "Null" Else rs.Fields("RetentionPolicyName").Value = myItem.RetentionPolicyName
rs.Fields("RTFBody").Value = Left(CStr(myItem.RTFBody), 300)
rs.Fields("Saved").Value = myItem.Saved
rs.Fields("SaveSentMessageFolder").Value = myItem.SaveSentMessageFolder
rs.Fields("Sender").Value = myItem.Sender
rs.Fields("SenderEmailAddress").Value = myItem.SenderEmailAddress
rs.Fields("SenderEmailType").Value = myItem.SenderEmailType
rs.Fields("SenderName").Value = myItem.SenderName
rs.Fields("SendUsingAccount").Value = myItem.SendUsingAccount
rs.Fields("Sensitivity").Value = myItem.Sensitivity
rs.Fields("Sent").Value = myItem.Sent
rs.Fields("SentOn").Value = myItem.SentOn
rs.Fields("SentOnBehalfOfName").Value = myItem.SentOnBehalfOfName
rs.Fields("Session").Value = myItem.Session
rs.Fields("Size").Value = myItem.Size
If myItem.Subject = "" Then rs.Fields("Subject").Value = "from:VBA Nontitle" Else rs.Fields("Subject").Value = myItem.Subject
rs.Fields("Submitted").Value = myItem.Submitted
rs.Fields("TaskCompletedDate").Value = myItem.TaskCompletedDate
rs.Fields("TaskDueDate").Value = myItem.TaskDueDate
rs.Fields("TaskStartDate").Value = myItem.TaskStartDate
If myItem.TaskSubject = "" Then rs.Fields("TaskSubject").Value = "Null" Else rs.Fields("TaskSubject").Value = myItem.TaskSubject
If myItem.To = "" Then rs.Fields("To").Value = "Null" Else rs.Fields("To").Value = Left(myItem.To, 200)
rs.Fields("ToDoTaskOrdinal").Value = myItem.ToDoTaskOrdinal
rs.Fields("UnRead").Value = myItem.UnRead
'rs.Fields("UserProperties").Value = myItem.UserProperties '<<
If myItem.VotingOptions = "" Then rs.Fields("VotingOptions").Value = "Null" Else rs.Fields("VotingOptions").Value = myItem.VotingOptions
If myItem.VotingResponse = "" Then rs.Fields("VotingResponse").Value = "Null" Else rs.Fields("VotingResponse").Value = myItem.VotingResponse
If Err.Number <> 0 Then
Debug.Print myItem.Subject, Err.Number, Err.Description
Err.Clear
rs.Update
GoTo Continue
Else
rs.Update
If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description, myItem.Subject, myItem.ReceivedTime: Err.Clear
rs.Move 0
GoTo Continue
End If
Continue:
Next
GoTo ERR_Handle
Exit Sub
ERR_Handle:
rs.Close
db.Close
Set myNaSp = Nothing
Set myFolder = Nothing
End Sub
Function replacetext(str As String) As String
str = Replace(str, Chr(10), "", 1, -1, vbTextCompare)
str = Replace(str, Chr(13), "", 1, -1, vbTextCompare)
str = Replace(str, vbTab, "", 1, -1, vbTextCompare)
str = Replace(str, " ", "", 1, -1, vbTextCompare)’Hankaku
str = Replace(str, " ", "", 1, -1, vbTextCompare)’Zenkaku
str = Replace(str, ",", "", 1, -1, vbTextCompare)
str = Replace(str, "＝＝＝", "", 1, -1, vbTextCompare)
replacetext = str
End Function
Function SetDAOProperty( _
WhichObject As Object, _
PropertyName As String, _
PropertyType As Integer, _
PropertyValue As Variant _
) As Boolean
On Error GoTo ErrorHandler
Dim prp As DAO.Property
WhichObject.Properties(PropertyName) = PropertyValue
WhichObject.Properties.Refresh
SetDAOProperty = True
Cleanup:
Set prp = Nothing
Exit Function
ErrorHandler:
Select Case Err.Number
Case 3270 ' "Property not found"
Set prp = WhichObject.CreateProperty( _
PropertyName, _
PropertyType, _
PropertyValue _
)
WhichObject.Properties.Append prp
WhichObject.Properties.Refresh
SetDAOProperty = True
Case Else
MsgBox Err.Number & ": " & Err.Description
SetDAOProperty = False
End Select
Resume Cleanup
End Function
###削除クエリ
今回のACCESSVBAはテーブルを最初から作るようなことはしないので、リストを作るマクロを何度も使うとデータ（レコード）が重複してしまう。
そのためアクションクエリとしてtest2の全レコードを削除するVBAを作る
これはテストの時テーブルにを何もない状態に戻すためのもので、必ず必要なものではありません。
また完成したテーブルには絶対に適用しないでください。
DeleteRecordALL.BAS
Sub DeleteRecordALL()
'Delete All Record From test2
Dim DB As Database: Set DB = CurrentDb
Dim sSQL As String
Dim Q As QueryDef
sSQL = "DELETE test2.Application, test2.Attachments FROM test2;"
DoCmd.SetWarnings False
DoCmd.RunSQL sSQL, True
DoCmd.SetWarnings True
End Sub
###あとは自分が欲しい検索条件のクエリを作成する
また、文字数はカットしているので、足りないときは増やすなど、適宜調整してください。