copy e-mail to database

Option Explicit
 
Sub EnumerateFoldersInStores()
    Dim colStores As Outlook.Stores
    Dim oStore As Outlook.Store
    Dim oRoot As Outlook.Folder
    
    On Error Resume Next
    Set colStores = Application.Session.Stores
    For Each oStore In colStores
        Set oRoot = oStore.GetRootFolder
        Debug.Print " - " & (oRoot.FolderPath) & " - "
        EnumerateFolders oRoot
    Next
End Sub
 
Private Sub EnumerateFolders(ByVal OFolder As Outlook.Folder)
    Dim folders As Outlook.folders
    Dim Folder As Outlook.Folder
    Dim foldercount As Integer
    Dim oItem As MailItem
    Dim oAttachment As Attachment
    Dim iCount As Integer
    Dim adoCon As Object, _
        strFields As String, _
        varValues As Variant, _
        strKey As String, _
        strPath As String
    
    
        Const ATTACHMENTFOLDER = "C:\Temper\1\Outlook Attachments\"
        
    On Error Resume Next
    Set folders = OFolder.folders
    foldercount = folders.Count
    
        'Check if there are any folders below oFolder
    iCount = 0
    If foldercount Then
        strFields = "Bcc,Body,BodyFormat,Categories,Cc,CreationTime,HTMLBody,Importance,SenderName,Sensitivity,Subject,SentTo,MsgID"
        Set adoCon = CreateObject("ADODB.Connection")
            'Change the name and path of the database on the next line
        adoCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Temper\1\Outlook.Mdb;Persist Security Info=False"
                For Each Folder In folders
                    For Each oItem In OFolder.Items
                            With oItem
                                strKey = Format(Now, "yyyymmdd") & "-" & Timer()
                                varValues = "'" & FixTextField(.BCC) & "'" _
                                                & ",'" & FixTextField(.Body) & "'" _
                                                & "," & .BodyFormat _
                                                & ",'" & FixTextField(.Categories) & "'" _
                                                & ",'" & FixTextField(.CC) & "'" _
                                                & ",'" & .CreationTime & "'" _
                                                & ",'" & FixTextField(.HTMLBody) & "'" _
                                                & "," & .Importance _
                                                & ",'" & FixTextField(.SenderName) & "'" _
                                                & "," & .Sensitivity _
                                                & ",'" & FixTextField(.Subject) & "'" _
                                                & ",'" & FixTextField(.To) & "'" _
                                                & ",'" & strKey & "'"
                            End With
                                Debug.Print "   " & " + " & oItem.Subject
                                    'Change the table name "Messages" on the following line as needed
                            adoCon.Execute "INSERT INTO Messages (" & strFields & ") VALUES(" & varValues & ")"
                            
                        For Each oAttachment In oItem.Attachments
                            strPath = ATTACHMENTFOLDER & strKey & " - " & oAttachment.FileName
                            oAttachment.SaveAsFile strPath
                            adoCon.Execute "INSERT INTO Attachments (MsgID,FileLink) VALUES('" & strKey & "','" & strPath & "')"
                            iCount = iCount + 1
                            Debug.Print "True" & " " & iCount & " " & oAttachment.FileName
    
                        Next oAttachment
                            iCount = 0
                    Next oItem
                
                    Debug.Print (Folder.FolderPath)
                    EnumerateFolders Folder
                Next
 
    End If
        adoCon.Close
        Set adoCon = Nothing
End Sub
Function FixTextField(varValue) As Variant
    FixTextField = Replace(Replace(varValue, Chr(34), Chr(34) & Chr(34)), "'", "''")
End Function

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87: