Question : Extract Outlook 2007 Journal Items and Attachments into Access 2007

I have a user who has used Outlook 2007 Journalling as a mini CRM, now we are moving to a larger bespoke hosted cloud solution but I need to send the data in a importable format to the cloud host

I know I can export the journal and have managed to export the journal, contacts an create a Company, Contacts and History database, however in my naivety I missed the attachments so need to start again!!

So I need to do the following from within Access 2007
1 Cycle through each journal item and create a record in Access
2 within each journal item cycle through any attachments if any and save them with a numeric filename (The same ID as the record I just created and a 2nd column with the file number), name etc...

Thanks in advance, the basic structure should be sufficient for me to continue myself

Paul

write some Access Code to scan through each journal item and create a record ijn my access

Answer : Extract Outlook 2007 Journal Items and Attachments into Access 2007

Working Code

                       
         
           
             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:

           
           
             Sub ScanJournals()
'Set up Outlook objects.
Dim ol As New Outlook.Application
Dim olns As Outlook.Namespace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.JournalItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty
Dim mvAtt As Outlook.Attachment
Dim mvX As Long
Dim mvXatt As Long
 
Dim DB As DAO.Database
Dim rstJournal As DAO.Recordset
Dim rstAttachments As DAO.Recordset
 
    
Set olns = ol.GetNamespace("MAPI")
Set cf = olns.GetDefaultFolder(olFolderJournal)
Set objItems = cf.Items
iNumContacts = objItems.Count
 
Set DB = CurrentDb
Set rstJournal = DB.OpenRecordset("Select * from Journal", dbOpenDynaset, dbSeeChanges)
Set rstAttachments = DB.OpenRecordset("Select * from Attachments", dbOpenDynaset, dbSeeChanges)
   
If iNumContacts <> 0 Then
    For i = 1 To iNumContacts
    Set c = objItems(i)
    
    'Save the Journal Entry
    rstJournal.AddNew
    rstJournal![journal type] = c.Type
    rstJournal!Subject = c.Subject
    rstJournal![start date] = c.Start
    rstJournal!Categories = c.Categories
    rstJournal!Companies = c.Companies
    rstJournal![Contact (Name)] = c.ContactNames
    rstJournal!Duration = c.Duration
    rstJournal![billing information] = c.BillingInformation
    rstJournal!Mileage = c.Mileage
    rstJournal!Body = c.Body
    rstJournal.Update
    rstJournal.Bookmark = rstJournal.LastModified
    mvXatt = 1
    For Each Att In c.Attachments
        Set mvAtt = c.Attachments(mvXatt)
        rstAttachments.AddNew
        rstAttachments!journalid = rstJournal!journalid
        rstAttachments!Description = mvAtt.FileName
        rstAttachments!FileName = "c:\temp\alchemy\" & rstJournal!journalid & mvXatt & Mid(mvAtt.FileName, InStr(mvAtt.FileName, "."), 10)
        mvAtt.SaveAsFile rstAttachments!FileName
        rstAttachments.Update
        mvXatt = mvXatt + 1
     Next Att
    Next i
Else
   MsgBox "No contacts to export."
End If
 
rstAttachments.Close
rstJournal.Close
Set DB = Nothing
 
End Sub
           
         

Open in New Window

Select All