Outlookで電子メールを追跡するためのAccessデータベースを開発しようとしています。多くのインターネット検索の断片を組み合わせることで、次のコードを開発することができました。添付されたコードは最終的に機能し、開発することを認めるよりも時間がかかりました。私はVBAプログラミングに不慣れで、プロセスをうんざりさせようとしています。とにかく、このプロジェクトが思ったよりも長くかかるのではないかという欲求不満と恐怖から、ようやく助けを求めたいと思いました。以下は、優先度の高い順に、最終的に以下のコードに追加したい機能です。
優先度が高い：
（1）すべてのサブフォルダーにある電子メールをインポートするには、再帰的なVBAコードが必要です。（2）電子メールが配置されているフォルダー名をAccessデータベースに挿入するにはVBAコードが必要です。フォルダパスは必要ありません。（3）ユーザーが添付したドキュメントのファイル名を挿入するにはVBAコードが必要です。
低優先度（問題が解決するまで、Accessを使用して重複を削除できます）：
（4）マクロの実行時にVBAコードに新しい電子メールでデータを追加する必要があります。
素晴らしい将来のオプション：
（5）フォルダを選択できるようにするVBAコード。オプションは将来の柔軟性を可能にします。
Windows 7（64ビットコンピューター）でAccessとOutlook2010を実行しています。これまでの私のコードは次のとおりです。
Sub ImportContactsFromOutlook()
' This code is based in Microsoft Access.
' Set up DAO objects (uses existing "tblContacts" table)
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("Email")
' Set up Outlook objects.
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.MailItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty
Set olns = ol.GetNamespace("MAPI")
'--- (5) --- VBA code to allow me to pick a folder. Option would allow for future flexability.
Set cf = olns.GetDefaultFolder(olPublicFoldersAllPublicFolders)
'--- (1) --- Need recursive VBA code to import emails located in all subfolders.
Set objItems = cf.Items
iNumMessages = objItems.Count
If iNumMessages <> 0 Then
For i = 1 To iNumMessages
If TypeName(objItems(i)) = "MailItem" Then
Set c = objItems(i)
rst.AddNew
rst!EntryID = c.EntryID
rst!ConversationID = c.ConversationID
rst!Sender = c.Sender
rst!SenderName = c.SenderName
rst!SentOn = c.SentOn
rst!To = c.To
rst!CC = c.CC
rst!BCC = c.BCC
rst!Subject = c.Subject
rst!Attachments = c.Attachments.Count
'--- (3) --- Need VBA code to insert the file name of any user attached documents. ".Count" is used to avoid error and can be replaced.
rst!Body = c.Body
rst!HTMLBody = c.HTMLBody
rst!Importance = c.Importance
rst!Size = c.Size
rst!CreationTime = c.CreationTime
rst!ReceivedTime = c.ReceivedTime
rst!ExpiryTime = c.ExpiryTime
'--- (2) --- Need VBA code to insert the Folder name where the email is located into Access Database. Folder Path is not necessary.
rst.Update
End If
Next i
rst.Close
MsgBox "Finished."
Else
MsgBox "No e-mails to export."
End If
'--- (4) --- Want VBA code to append data with new emails when macro is run.
End Sub
これが私が使おうとしたいくつかの役立つ参考資料です。それらのいくつかは、派手なツールのように見えたものを持っています。私は学んでいるので、それらのいくつかを実装できなかったか、理解できませんでした。
- msdn.microsoft.com/en-us/library/ee861519(v=office.14).aspx
- msdn.microsoft.com/en-us/library/office/ee861520(v=office.14).aspx
- accessexperts.net/blog/2011/07/07/importing-outlook-emails-into-access/
- add-in-express.com/creating-addins-blog/2011/08/15/how-to-get-list-of-attachments/
- databasejournal.com/features/msaccess/article.php/3827996/Working-With-Outlook-from-Access.htm
- stackoverflow.com/questions/7298591/copying-all-incoming-emails-in-outlook-inbox-and-personal-subfolders-to-excel-th
任意の推奨事項や方向性を歓迎します。助けてくれてありがとう。ありがたいです。
これが現在の私のコードです（以下を参照）。私がそれを実行するとき、まだいくつかの問題があります。コードを初めて実行すると、Accessデータベーステーブルにレコードがないため、次のエラーが発生します。
実行時エラー「3021」：現在のレコードがありません。
エラーチェックまたはこれを回避するためのコーディング方法はありますか？また、Accessデータベースにデータが入力された後、次のコードは、サブフォルダーではなく、プライマリフォルダーで見つかった電子メールのみを除外します。
If ([rst]![EmailLocation] <> ofProp.Name) And ([rst]![EntryID] <> cMail.EntryID) Then
私はその理由を理解しようとしています。最後に、ユーザーが添付したドキュメントのリストをアクセスデータベースにプルする方法を知る必要があります。次のコードは、埋め込まれた添付ファイルを含むすべての添付ファイルをプルし、ドキュメントの最初の添付ファイルのみを返します。
Set cAtch = cMail.Attachments
cntAtch = cAtch.Count
If cntAtch > 0 Then
For j = cntAtch To 1 Step -1
strAtch = cAtch.Item(j).FileName
rst!Attachments = strAtch
Next
Else
rst!Attachments = "No Attachments"
End If
繰り返しになりますが、どんな助けもいただければ幸いです。ありがとう。
Sub ImportMailPropFromOutlook()
' Code for specifing top level folder and initializing routine.
' Set up Outlook objects.
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim ofO As Outlook.MAPIFolder
Dim ofSubO As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Set olns = ol.GetNamespace("MAPI")
Set ofO = olns.GetDefaultFolder(olFolderInbox) '--- Specifies top level folder for importing Oultook mail.
'Set of = olns.PickFolder '--- Allows user to select top level folder for importing Outlook mail.
'Set info and call GetMailProp code.
Set objItems = ofO.Items
GetMailProp objItems, ofO
'Set info and call ProcessSubFolders.
For Each ofSubO In of.Folders
Set objItems = ofSubO.Items
ProcessSubFolders objItems, ofSubO
Next
End Sub
Sub GetMailProp(objProp As Outlook.Items, ofProp As Outlook.MAPIFolder)
' Code for writeing Outlook mail properties to Access.
' Set up DAO objects (uses existing Access "Email" table).
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("Email")
'Set Up Outlook objects.
Dim cMail As Outlook.MailItem
Dim cAtch As Outlook.Attachments
'Write Outlook mail properties to Access "Email" table.
iNumMessages = objProp.Count
If iNumMessages <> 0 Then
For i = 1 To iNumMessages
If TypeName(objProp(i)) = "MailItem" Then
Set cMail = objProp(i)
If ([rst]![EmailLocation] <> ofProp.Name) And ([rst]![EntryID] <> cMail.EntryID) Then
rst.AddNew
rst!EntryID = cMail.EntryID
rst!ConversationID = cMail.ConversationID
rst!Sender = cMail.Sender
rst!SenderName = cMail.SenderName
rst!SentOn = cMail.SentOn
rst!To = cMail.To
rst!CC = cMail.CC
rst!BCC = cMail.BCC
rst!Subject = cMail.Subject
Set cAtch = cMail.Attachments
cntAtch = cAtch.Count
If cntAtch > 0 Then
For j = cntAtch To 1 Step -1
strAtch = cAtch.Item(j).FileName
rst!Attachments = strAtch
Next
Else
rst!Attachments = "No Attachments"
End If
rst!Count = cMail.Attachments.Count
rst!Body = cMail.Body
rst!HTMLBody = cMail.HTMLBody
rst!Importance = cMail.Importance
rst!Size = cMail.Size
rst!CreationTime = cMail.CreationTime
rst!ReceivedTime = cMail.ReceivedTime
rst!ExpiryTime = cMail.ExpiryTime
rst!EmailLocation = ofProp.Name
rst.Update
End If
End If
Next i
End If
End Sub
Sub ProcessSubFolders(objItemsR As Outlook.Items, OfR As Outlook.MAPIFolder)
'Code for processing subfolders
' Set up Outlook objects.
Dim ofSubR As Outlook.MAPIFolder
'Set info and call GetMailProp code.
GetMailProp objItemsR, OfR
'Set info and call ProcessSubFolders. Recursive.
For Each ofSubR In OfR.Folders
Set objItemsR = ofSubR.Items
ProcessSubFolders objItemsR, ofSubR
Next
End Sub
私はもう少しコードに取り組む機会がありました。私がやろうとしているのは、Outlookアカウントのすべてのサブフォルダー内にある電子メールをAccessにインポートすることです。VBAコードはAccessにあります。特定のメールアイテムのプロパティのみが必要です。ほとんどの場合、Outlookでメモの印刷機能を複製する必要があります。
同じフォルダにある重複を除外するために必要だと思ったものをさらにいくつか追加しました。は異なるパブリックサブフォルダに重複する電子メールですが、データベースレコードでそれを知る必要があります。
すべてのサブフォルダーを確実に取得するには、再帰的なサブまたは関数が必要です。For / Nextループを試しましたが、これは1レベルのサブフォルダーのみを検索します。私はこれについていくつかの助けを断固として使うことができました。これは難しい部分のようです。
私の更新されたコードは次のとおりです。
Sub ImportContactsFromOutlook()
' This code is based in Microsoft Access.
' Set up DAO objects (uses existing "Email" table)
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("Email")
' Set up Outlook objects.
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim cMail As Outlook.MailItem
Dim cAtch As Outlook.Attachments
Dim objItems As Outlook.Items
Dim of As Outlook.Folder
Dim ofSub As Outlook.Folder
Set olns = ol.GetNamespace("MAPI")
'--- (5) ---
'Would eventually be nice to allow a user to select a folder. Folderpicker? Lowest priority.
Set of = olns.GetDefaultFolder(olFolderInbox)
'--- (1) ---
'Loop only searches one level down. I will need all subfolders. Most examples I saw call external Sub? Recursive?
For Each ofSub In of.Folders
Set objItems = ofSub.Items
iNumMessages = objItems.Count
If iNumMessages <> 0 Then
For i = 1 To iNumMessages
If TypeName(objItems(i)) = "MailItem" Then
Set cMail = objItems(i)
rst.AddNew
rst!EntryID = cMail.EntryID
rst!ConversationID = cMail.ConversationID
rst!Sender = cMail.Sender
rst!SenderName = cMail.SenderName
rst!SentOn = cMail.SentOn
rst!To = cMail.To
rst!CC = cMail.CC
rst!BCC = cMail.BCC
rst!Subject = cMail.Subject
'--- (3) ---
'Code only inserts first attachment. Code Also inserts embedded attachments.
'Need code to insert all user selected attachments (ex. PDF Document) and no embedded attachments.
Set cAtch = cMail.Attachments
cntAtch = cAtch.Count
If cntAtch > 0 Then
For j = cntAtch To 1 Step -1
strAtch = cAtch.Item(j).FileName
rst!Attachments = strAtch
Next
Else
rst!Attachments = "No Attachments"
End If
rst!Count = cMail.Attachments.Count
rst!Body = cMail.Body
rst!HTMLBody = cMail.HTMLBody
rst!Importance = cMail.Importance
rst!Size = cMail.Size
rst!CreationTime = cMail.CreationTime
rst!ReceivedTime = cMail.ReceivedTime
rst!ExpiryTime = cMail.ExpiryTime
'--- (2) ---
' Solved - Figured out how to call folder location into databse.
rst!EmailLocation = ofSub.Name
rst.Update
End If
Next i
End If
Next
'--- (4) ---
'Still need code to append Access database with only new records.
'Duplicate email can exist in differenc subfolders but not same subfolder.
End Sub
どんな助けでもいただければ幸いです。