Solved

Import Outlook 2007 Messages to Access 2007/SQL table including file attachments

Posted on 2009-07-15
6
564 Views
Last Modified: 2013-11-28
Hi
I'm trying to find a way of importing email messages along with their file attachments to a access 2007 table or MS SQL linked table (preffered) then delete the messages from the outlook folder.

I've managed to link the outlook folder to access and view messages via a form but as yet been unable to do find the atachments or successfully automate the import of the outlook data to either a local table or linked sql table.

Any help would be appreciated

thanks

Mark
0
Comment
Question by:MarkStones
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
  • 2
6 Comments
 
LVL 20

Expert Comment

by:darbid73
ID: 24858356
I do not know how you are getting your email object but below is one way which is getting the currently selected email.

Once you have an email you need to use the Attachments collection to loop through all of the attachments to the email.

In my example it loops though the attachments and saves each attachment of the email to C drive.

In this part you could do anything you like including saving it to an open record set or what ever you like.




Dim out_Exp As Outlook.Explorer
Dim out_Sel As Outlook.Selection
Dim out_mail As Outlook.MailItem
Dim out_att As Outlook.Attachment
 
 
'get the active explorer
Set out_Exp = Outlook.ActiveExplorer
 
'get a collection of what is selected use this to make sure only one email is selected
Set out_Sel = out_Exp.Selection
 
 
Set out_mail = out_Sel.Item(1)
 
For Each out_att In out_mail.Attachments
 
    Debug.Print out_att.DisplayName
 
 
out_att.SaveAsFile "C:\" & out_att.DisplayName
 
 
Next out_att
 
'delete the email.
out_mail.Delete

Open in new window

0
 
LVL 31

Expert Comment

by:Helen_Feddema
ID: 24868819
Here is some code that loads saved attachments to an Attachments-type field in an Access 2007 database.  
Public Function SaveAttachments()
 
On Error GoTo ErrorHandler
   
   Set appWord = GetObject(, "Word.Application")
   strDefaultDocsPath = appWord.Options.DefaultFilePath(wdDocumentsPath) & "\"
   strDocsPath = GetProperty("OutputDocsPath", strDefaultDocsPath)
   Debug.Print "Output docs path: " & strDocsPath
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fld = fso.GetFolder(strDocsPath)
   Set dbs = CurrentDb
   Set rstTable = dbs.OpenRecordset("tblContacts")
   
   Do While Not rstTable.EOF
         'Create recordset of attachments for this record
         Set rstAttachments = _
            rstTable.Fields("File").Value
         With rstAttachments
            Do While Not .EOF
               strFileAndPath = strDocsPath _
                  & .Fields("FileName")
               
               'Save this attachment to a file in the Output
               'Docs folder
               Debug.Print "Saving " & strFileAndPath _
                  & " to " & strDocsPath & " folder"
 
               'Turn off error handler to prevent errors if
               'the file already exists in the folder.
               
On Error Resume Next
 
               .Fields("FileData").SaveToFile strFileAndPath
               .MoveNext
            Loop
            .Close
         End With
         rstTable.MoveNext
   Loop
   
   rstTable.Close
   strPrompt = "All new attachments saved to " _
      & strDocsPath & " folder"
   strTitle = "Done!"
   MsgBox strPrompt, vbOKOnly + vbInformation, strTitle
   
ErrorHandlerExit:
   Exit Function
 
ErrorHandler:
   If Err = 429 Then
      'Word is not running; open Word with CreateObject
      Set appWord = CreateObject("Word.Application")
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number & "; Description: " _
         & Err.Description
      Resume ErrorHandlerExit
   End If
 
End Function
 
On Error GoTo ErrorHandler
   
   Set appWord = GetObject(, "Word.Application")
   strDefaultDocsPath = appWord.Options.DefaultFilePath(wdDocumentsPath) & "\"
   strDocsPath = GetProperty("InputDocsPath", strDefaultDocsPath)
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fld = fso.GetFolder(strDocsPath)
   Set dbs = CurrentDb
   Set rstTable = dbs.OpenRecordset("tblContacts", dbOpenDynaset)
   
   For Each fil In fld.Files
      strFile = fil.Name
      Debug.Print "File name: " & strFile
      Debug.Print "File type: " & fil.Type
      
      'Check whether file name starts with 'Contact ID'
      If Left(strFile, 10) = "Contact ID" Then
         'Extract Contact ID from file name, using Mid and
         'InStr to start at the beginning of the number and
         'end before the space following the number,
         'if there is one
         strTest = Mid(String:=strFile, Start:=12, Length:=3)
         intSpace = InStr(strTest, " ")
         
         If intSpace > 0 Then
            lngContactID = CLng(Mid(String:=strTest, _
               Start:=1, Length:=intSpace - 1))
         Else
            lngContactID = CLng(strTest)
         End If
         
         strSearch = "[ContactID] = " & lngContactID
         Debug.Print "Search string: " & strSearch
         strFileAndPath = strDocsPath & strFile
         
         'Search for matching Contact ID in table
         rstTable.MoveFirst
         rstTable.FindFirst strSearch
         If rstTable.NoMatch = True Then
            strTitle = "Can't find contact"
            strPrompt = "Contact ID " & lngContactID _
               & " not found in table; can't add attachment"
            GoTo NextDoc
         Else
            rstTable.Edit
            'Create recordset of attachments for this record
            Set rstAttachments = _
               rstTable.Fields("File").Value
               
         'Turn off error handler to prevent errors if the
         'code attempts to add the same file twice; in this
         'case the Attachments recordset won't be updated
On Error Resume Next
               
            With rstAttachments
               .AddNew
               .Fields("FileData").LoadFromFile _
                  (strFileAndPath)
               .Update
               .Close
            End With
            rstTable.Update
            Debug.Print "Added " & strFileAndPath _
               & " as attachment to Contact ID " _
               & lngContactID; "'s record"
         End If
      End If
      
NextDoc:
   Next fil
   
   'Open Contacts form to see the attachments
   'that have been loaded
   DoCmd.OpenForm FormName:="frmContacts"
   
ErrorHandlerExit:
   Exit Function
 
ErrorHandler:
   If Err = 429 Then
      'Word is not running; open Word with CreateObject
      Set appWord = CreateObject("Word.Application")
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number & "; Description: " _
         & Err.Description
      Resume ErrorHandlerExit
   End If
   
End Function

Open in new window

0
 
LVL 31

Accepted Solution

by:
Helen_Feddema earned 500 total points
ID: 24868837
Sorry, that was the SaveAttachments function -- maybe you can use that too.  Here is the LoadAttachments function.
Public Function LoadAttachments()
 
On Error GoTo ErrorHandler
   
   Set appWord = GetObject(, "Word.Application")
   strDefaultDocsPath = appWord.Options.DefaultFilePath(wdDocumentsPath) & "\"
   strDocsPath = GetProperty("InputDocsPath", strDefaultDocsPath)
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fld = fso.GetFolder(strDocsPath)
   Set dbs = CurrentDb
   Set rstTable = dbs.OpenRecordset("tblContacts", dbOpenDynaset)
   
   For Each fil In fld.Files
      strFile = fil.Name
      Debug.Print "File name: " & strFile
      Debug.Print "File type: " & fil.Type
      
      'Check whether file name starts with 'Contact ID'
      If Left(strFile, 10) = "Contact ID" Then
         'Extract Contact ID from file name, using Mid and
         'InStr to start at the beginning of the number and
         'end before the space following the number,
         'if there is one
         strTest = Mid(String:=strFile, Start:=12, Length:=3)
         intSpace = InStr(strTest, " ")
         
         If intSpace > 0 Then
            lngContactID = CLng(Mid(String:=strTest, _
               Start:=1, Length:=intSpace - 1))
         Else
            lngContactID = CLng(strTest)
         End If
         
         strSearch = "[ContactID] = " & lngContactID
         Debug.Print "Search string: " & strSearch
         strFileAndPath = strDocsPath & strFile
         
         'Search for matching Contact ID in table
         rstTable.MoveFirst
         rstTable.FindFirst strSearch
         If rstTable.NoMatch = True Then
            strTitle = "Can't find contact"
            strPrompt = "Contact ID " & lngContactID _
               & " not found in table; can't add attachment"
            GoTo NextDoc
         Else
            rstTable.Edit
            'Create recordset of attachments for this record
            Set rstAttachments = _
               rstTable.Fields("File").Value
               
         'Turn off error handler to prevent errors if the
         'code attempts to add the same file twice; in this
         'case the Attachments recordset won't be updated
On Error Resume Next
               
            With rstAttachments
               .AddNew
               .Fields("FileData").LoadFromFile _
                  (strFileAndPath)
               .Update
               .Close
            End With
            rstTable.Update
            Debug.Print "Added " & strFileAndPath _
               & " as attachment to Contact ID " _
               & lngContactID; "'s record"
         End If
      End If
      
NextDoc:
   Next fil
   
   'Open Contacts form to see the attachments
   'that have been loaded
   DoCmd.OpenForm FormName:="frmContacts"
   
ErrorHandlerExit:
   Exit Function
 
ErrorHandler:
   If Err = 429 Then
      'Word is not running; open Word with CreateObject
      Set appWord = CreateObject("Word.Application")
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number & "; Description: " _
         & Err.Description
      Resume ErrorHandlerExit
   End If
   
End Function

Open in new window

0
Simplifying Server Workload Migrations

This use case outlines the migration challenges that organizations face and how the Acronis AnyData Engine supports physical-to-physical (P2P), physical-to-virtual (P2V), virtual to physical (V2P), and cross-virtual (V2V) migration scenarios to address these challenges.

 
LVL 31

Expert Comment

by:Helen_Feddema
ID: 24868888
Both of these functions are from my Access Archon article #188, Working with the New Access 2007 Attachments field.  I tried to attach a zip with the article and sample database, but the .accdb file was rejected.  Here is a link for downloading the zip:  http://www.helenfeddema.com/Files/accarch188.zip
0
 
LVL 20

Expert Comment

by:darbid73
ID: 24876441
At the risk of getting a little bit off topic - Hello Helen - You saved me when learning how to automate Word from Access.  You have some great tutorials on this on your website.  Thank you Thank you.
0
 
LVL 31

Expert Comment

by:Helen_Feddema
ID: 24879041
darbid73 -- you might be interested in my new ebook, Working with Word, which is all about moving data from Access to Word.  Here is a link for it:  http://shop.office-watch.com/aww/
0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Describes a method of obtaining an object variable to an already running instance of Microsoft Access so that it can be controlled via automation.
It’s been over a month into 2017, and there is already a sophisticated Gmail phishing email making it rounds. New techniques and tactics, have given hackers a way to authentically impersonate your contacts.How it Works The attack works by targeti…
In Microsoft Access, learn the trick to repeating sub-report headings at the top of each page. The problem with sub-reports and headings: Add a dummy group to the sub report using the expression =1: Set the “Repeat Section” property of the dummy…
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

740 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question