asked on

copy e-mail to database

I am working with a number of large e-mail accounts I would like to automate copying the messages, to a database (access) moving attachments to the hard drive with a link to the file in the data base.

I fine this code works well except I have to select each message, can someone help me incorporate the EnumerateFoldersInStores code with the ExportMessageToAccess code so as to select the top most directory in Outlook and walk through each message in each folder and sub folder copying and extracting automatically?

Sub ExportMessageToAccess()
    'Edit the path on the following line.  This is the path to the folder where attachments will be stored.
    Const ATTACHMENTFOLDER = "C:\Temper\1\"
    Dim olkMessage As Outlook.MailItem, _
        olkAttachment As Outlook.Attachment, _
        adoCon As Object, _
        strFields As String, _
        varValues As Variant, _
        strKey As String, _
        strPath As String
 
    strFields = "Bcc,Body,BodyFormat,Categories,Cc,CreationTime,HTMLBody,Importance,SenderName,Sensitivity,Subject,SentTo,MsgID"
    Set adoCon = CreateObject("ADODB.Connection")
 
    adoCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Temper\1\Outlook.Mdb;Persist Security Info=False"
    Set olkFolder = Session.GetDefaultFolder(olFolderInbox).Items
    
    Set olkMessage = Application.ActiveExplorer.Selection(1)
    With olkMessage
        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
    'Change the table name "Messages" on the following line as needed
    adoCon.Execute "INSERT INTO Messages (" & strFields & ") VALUES(" & varValues & ")"
    For Each olkAttachment In olkMessage.Attachments
        strPath = ATTACHMENTFOLDER & strKey & " - " & olkAttachment.FileName
        olkAttachment.SaveAsFile strPath
        adoCon.Execute "INSERT INTO Attachments (MsgID,FileLink) VALUES('" & strKey & "','" & strPath & "')"
        Debug.Print strKey, strPath
    Next
    adoCon.Close
    Set adoCon = Nothing
    Set olkMessage = Nothing
End Sub
 
Function FixTextField(varValue) As Variant
    FixTextField = Replace(Replace(varValue, Chr(34), Chr(34) & Chr(34)), "'", "''")
End Function
 
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
    
    On Error Resume Next
    Set folders = oFolder.folders
    foldercount = folders.Count
    'Check if there are any folders below oFolder
    If foldercount Then
        For Each Folder In folders
            Debug.Print (Folder.FolderPath)
            EnumerateFolders Folder
        Next
    End If
End Sub

Open in new window

ASKER CERTIFIED SOLUTION

aikimark

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

MarkW

ASKER

Too cool for school daddyo....Hey thanks aikimark, took me about 15-minutes!!!

Thanks to all those that posted code which I have not mentioned by name.

aikimark: Thank you!

Code posted for others

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

Open in new window

MarkW

ASKER

Too cool for school daddyo....Hey thanks aikimark, took me about 15-minutes!!!

Thanks to all those that posted code which I have not mentioned by name.

aikimark: Thank you!

Code posted for others