Solved

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

Posted on 2009-07-15
6
565 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
Back Up Your Microsoft Windows Server®

Back up all your Microsoft Windows Server – on-premises, in remote locations, in private and hybrid clouds. Your entire Windows Server will be backed up in one easy step with patented, block-level disk imaging. We achieve RTOs (recovery time objectives) as low as 15 seconds.

 
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

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

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…
AutoNumbers should increment automatically, without duplicates.  But sometimes something goes wrong, and the next AutoNumber value is a duplicate.  This article shows how to recover from this problem.
Learn how to number pages in an Access report over each group. Activate two pass printing by referencing the pages property: Add code to the Page Footers OnFormat event to capture the pages as there occur for each group. Use the pages property to …
In Microsoft Access, learn how to use Dlookup and other domain aggregate functions and one method of specifying a string value within a string. Specify the first argument, which is the expression to be returned: Specify the second argument, which …

732 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