Sub CreateNAddFile()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim bcmRootFolder As Outlook.Folder
Dim olFolders As Outlook.Folders
Dim bcmAccountsFldr As Outlook.Folder
Dim bcmContactsFldr As Outlook.Folder
Dim bcmHistoryFolder As Outlook.Folder
Dim bcmOppFolder As Outlook.Folder
Dim bcmProjFolder As Outlook.Folder
Dim newAcct As Outlook.ContactItem
Dim objFile As Outlook.JournalItem
Dim newContact As Outlook.ContactItem
Dim newOpportunity As Outlook.TaskItem
Dim newProject As Outlook.TaskItem
Dim userProp As Outlook.UserProperty
Set olApp = CreateObject("Outlook.Application")
Set objNS = olApp.GetNamespace("MAPI")
Set olFolders = objNS.Session.Folders
Set bcmRootFolder = olFolders("Business Contact Manager")
Set bcmAccountsFldr = bcmRootFolder.Folders("Accounts")
Set bcmContactsFldr = bcmRootFolder.Folders("Business Contacts")
Set bcmHistoryFolder = bcmRootFolder.Folders("Communication History")
MsgBox ("If you don't have a file C:\test.txt, double clicking it in the records history shows 'File Not found'")
Set newAcct = bcmAccountsFldr.Items.Add("IPM.Contact.BCM.Account")
newAcct.FullName = "Wide World Importers"
newAcct.FileAs = "Wide World Importers"
newAcct.Email1Address = "someone@example.com"
newAcct.Save
Set objFile = bcmHistoryFolder.Items.Add("IPM.Activity.BCM")
If (objFile.UserProperties("Parent Entity EntryID") Is Nothing) Then
Set userProp = objFile.UserProperties.Add("Parent Entity EntryID", olText, False, False)
userProp.Value = newAcct.EntryID
End If
objFile.Subject = "test.txt"
objFile.Type = "File"
If (objFile.UserProperties("LinkToOriginal") Is Nothing) Then
Set userProp = objFile.UserProperties.Add("LinkToOriginal", olText, False, False)
userProp.Value = "c:\test.txt"
End If
objFile.Save
Set newContact = bcmContactsFldr.Items.Add("IPM.Contact.BCM.Contact")
newContact.FullName = "John Smith"
newContact.FileAs = "John Smith"
newContact.Save
Set objFile = bcmHistoryFolder.Items.Add("IPM.Activity.BCM")
If (objFile.UserProperties("Parent Entity EntryID") Is Nothing) Then
Set userProp = objFile.UserProperties.Add("Parent Entity EntryID", olText, False, False)
userProp.Value = newContact.EntryID
End If
objFile.Subject = "test.txt"
objFile.Type = "File"
If (objFile.UserProperties("LinkToOriginal") Is Nothing) Then
Set userProp = objFile.UserProperties.Add("LinkToOriginal", olText, False, False)
userProp.Value = "c:\test.txt"
End If
objFile.Save
Set bcmOppFolder = bcmRootFolder.Folders("Opportunities")
Set newOpportunity = bcmOppFolder.Items.Add("IPM.Task.BCM.Opportunity")
newOpportunity.Subject = "Opportunity For Wide World Importers to enter into Retail Field"
If (newOpportunity.UserProperties("Parent Entity EntryID") Is Nothing) Then
Set userProp = newOpportunity.UserProperties.Add("Parent Entity EntryID", olText, False, False)
userProp.Value = newAcct.EntryID
End If
newOpportunity.Save
Set objFile = bcmHistoryFolder.Items.Add("IPM.Activity.BCM")
If (objFile.UserProperties("Parent Entity EntryID") Is Nothing) Then
Set userProp = objFile.UserProperties.Add("Parent Entity EntryID", olText, False, False)
userProp.Value = newOpportunity.EntryID
End If
objFile.Subject = "test.txt"
objFile.Type = "File"
If (objFile.UserProperties("LinkToOriginal") Is Nothing) Then
Set userProp = objFile.UserProperties.Add("LinkToOriginal", olText, False, False)
userProp.Value = "c:\test.txt"
End If
objFile.Save
Set bcmProjFolder = bcmRootFolder.Folders("Business Projects")
Set newProject = bcmProjFolder.Items.Add("IPM.Task.BCM.Project")
newProject.Subject = "Project For Wide World Importers to enter into Retail Field"
If (newProject.UserProperties("Parent Entity EntryID") Is Nothing) Then
Set userProp = newProject.UserProperties.Add("Parent Entity EntryID", olText, False, False)
userProp.Value = newAcct.EntryID
End If
newProject.Save
Set objFile = bcmHistoryFolder.Items.Add("IPM.Activity.BCM")
If (objFile.UserProperties("Parent Entity EntryID") Is Nothing) Then
Set userProp = objFile.UserProperties.Add("Parent Entity EntryID", olText, False, False)
userProp.Value = newProject.EntryID
End If
objFile.Subject = "test.txt"
objFile.Type = "File"
If (objFile.UserProperties("LinkToOriginal") Is Nothing) Then
Set userProp = objFile.UserProperties.Add("LinkToOriginal", olText, False, False)
userProp.Value = "c:\test.txt"
End If
objFile.Save
Set objFile = Nothing
Set objFile = bcmHistoryFolder.Items.Find("[Subject] = 'test.txt'")
Debug.Print objFile.UserProperties("Created/Due").Value
Set objFile = Nothing
Set existAcct = Nothing
Set newProject = Nothing
Set newOpportunity = Nothing
Set newContact = Nothing
Set bcmContactsFldr = Nothing
Set bcmProjFolder = Nothing
Set bcmAccountsFldr = Nothing
Set bcmHistoryFolder = Nothing
Set olFolders = Nothing
Set bcmRootFolder = Nothing
Set objNS = Nothing
Set olApp = Nothing