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

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

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

Sorry, that was the SaveAttachments function -- maybe you can use that too. Here is the LoadAttachments 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:
88:
89:
90:
91:
92:

           
           
             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

Select All