I need to create a macro in Outlook 2003 that (when invoked) deletes all contacts in a specific folder, then imports from a .csv file on the desktop into the (now empty) contacts folder.
Printable View
I need to create a macro in Outlook 2003 that (when invoked) deletes all contacts in a specific folder, then imports from a .csv file on the desktop into the (now empty) contacts folder.
Hi Zepharin,
Welcome to VBAX! We're glad you found us!
Here is a code sample that will delete items from a Contacts folders. This sample assumes the specific Contacts folder resides directly under the "Outlook Today - [Mailbox - <USERNAME>]" folder and that its name is "MyContacts".
If the folder resides somewhere else, such as underneath the built-in Contacts folder or in a .pst file, let me know and I can adjust the code for you. Otherwise, just rename the "MyContacts" folder in the example to the name you are using.
Because a Contacts folder can contain both contacts and distribution lists, you will see that the code checks the Class of each item in order to delete the correct object.
[vba]
Sub DeleteSpecialContacts()
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim olMyParentFolder As Outlook.MAPIFolder
Dim olMyContactsFolder As Outlook.MAPIFolder
Dim intCount As Integer
Dim objContact As ContactItem
Dim objDistList As DistListItem
On Error Goto ErrHandler
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olMyParentFolder = olNs.GetDefaultFolder(olFolderContacts).Parent
Set olMyContactsFolder = olMyParentFolder.Folders("MyContacts")
intCount = olMyContactsFolder.Items.Count
For i = intCount To 1 Step -1
Set olItem = olMyContactsFolder.Items(i)
Select Case olItem.Class
Case olContact
Set objContact = olMyContactsFolder.Items(i)
objContact.Delete
Case olDistributionList
Set objDistList = olMyContactsFolder.Items(i)
objDistList.Delete
End Select
Next
Exit Sub
ErrHandler:
MsgBox "An error ocurred in the procedure." & _
vbCr & "Error: " & err.number & _
vbCr & "Description: " & err.description, vbOKOnly+vbCritical, "Error"
End Sub
[/vba]
If you will post the structure of your CSV file, I can try to put together an import routine for you. I just need to know how the CSV file laid out and the type of fields you want to import.
Cheers,
James
The contacts folder in question ('Invest') is a sub-folder of the default 'Contacts' folder. The CSV is composed of two Coloums the left one being the contacts name the right one being the contacts phone number.
Example;
Thanks for all your helpQuote:
"John Smith","1234567890"
"Jane Smith","6041234567"
"John Doe","9999991111"
Zepharin,
Here is the revised code to delete contact items from the "Invest" folder under the default Contacts folder. I will work on an import routine for you.
James
[vba]
Sub DeleteSpecialContacts()
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim olMyParentFolder As Outlook.MAPIFolder
Dim olMyContactsFolder As Outlook.MAPIFolder
Dim intCount As Integer
Dim objContact As ContactItem
Dim objDistList As DistListItem
On Error Goto ErrHandler
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olMyParentFolder = olNs.GetDefaultFolder(olFolderContacts)
Set olMyContactsFolder = olMyParentFolder.Folders("Invest")
intCount = olMyContactsFolder.Items.Count
For i = intCount To 1 Step -1
Set olItem = olMyContactsFolder.Items(i)
Select Case olItem.Class
Case olContact
Set objContact = olMyContactsFolder.Items(i)
objContact.Delete
Case olDistributionList
Set objDistList = olMyContactsFolder.Items(i)
objDistList.Delete
End Select
Next
Exit Sub
ErrHandler:
MsgBox "An error ocurred in the procedure." & _
vbCr & "Error: " & err.number & _
vbCr & "Description: " & err.description, vbOKOnly+vbCritical, "Error"
End Sub
[/vba]
Zepharin,
Here is the import routine for you. I only used some very basic error checking, so you should probably enhance it.
If you don't want the user to select the csv file and know its location and file name, just remove the FileDialog section I marked and set the strFileName variable to your path and file name as shown.
Also, because of it's security model, Outlook will prompt the user each time a new contact is saved.
To use this sample:
1. Open your VBE from Outlook (Alt-F11)
2. Insert a new Module
3. Paste this sample into the module
Let us know how it works.
Cheers,
James
[vba]
Option Base 1
Public arrContacts() As String
Sub Main()
ReadCSV
CreateContactItem
End Sub
Sub ReadCSV()
'Opens the file and reads it's contents into an array
Dim strFileName, strName, strPhoneNumber As String
Dim fd As FileDialog
Dim i As Integer
On Error Resume Next
'/////////////////////////////////////////////////////////////////////////////////
'Remove this section if you want to hard-code the path and filename of
'the csv file.
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
If fd.Show = -1 Then
strFileName = fd.SelectedItems.Item(1)
Else
MsgBox "No file selected", vbOKOnly, "No file selected"
Exit Sub
End If
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \\\\\\\
'if you hard-cde the path and filename, set your strFileName like this:
' strFileName = "C:\MyPath\MyCSVFile"
Open strFileName For Input As #1
If Err.Number = 0 Then
i = 1
Do While Not EOF(1)
ReDim Preserve arrContacts(2, i)
Input #1, arrContacts(1, i), arrContacts(2, i)
i = i + 1
Loop
Close #1
Else
MsgBox "There was a problem opening the file."
Exit Sub
End If
End Sub
Sub CreateContactItem()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olNewContact As Outlook.ContactItem
Dim olMyParentFolder, olMyContactsFolder As Folders
Dim i As Integer
On Error GoTo errhandler
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olMyParentFolder = olNS.GetDefaultFolder(olFolderContacts)
Set olMyContactsFolder = olMyParentFolder.Folders("Invest")
'Create a contactitem for each array element
For i = LBound(arrContacts) To UBound(arrContacts)
Set olNewContact = olApp.CreateItem(olContactItem)
olNewContact.FullName = arrContacts(1, i)
olNewContact.BusinessTelephoneNumber = arrContacts(2, i)
olNewContact.SaveAs (olMyContactsFolder)
Next i
Exit Sub
errhandler:
MsgBox "An error occured." & vbCr & "Error: " & Err.Number & vbCr & "Description: " & _
Err.Description, vbOKOnly + vbCritical, "Error"
Set olNewContact = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set olMyParentFolder = Nothing
Set olMyContactsFolder = Nothing
End Sub
[/vba]
I tryed to run the module and I got an Error 13: Type Mismatch
Zepharin,
Can you step through the code and determine where the type mismatch occurs? If you aren't familiar with stepping through the code, follow these steps:
1. Open the code module in VBE
2. Press F8 to start the code - this will allow you to run one line at a time
3. Continue pressing F8 for each line
4. Note the line that causes the type mismatch to appear
I am also running OL2003, and had no problems.
Thanks,
James
Zepharin,
I was able to locate the problem. This sample should work for you.
Let us know.
James
[vba]
Option Base 1
Public arrContacts() As String
Sub Main()
ReadCSV
CreateContactItem
End Sub
Sub ReadCSV()
'Opens the file and reads it's contents into an array
Dim strFileName, strName, strPhoneNumber As String
Dim fd As FileDialog
Dim i As Integer
On Error Resume Next
'/////////////////////////////////////////////////////////////////////////////////
'Remove this section if you want to hard-code the path and filename of
'the csv file.
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
If fd.Show = -1 Then
strFileName = fd.SelectedItems.Item(1)
Else
MsgBox "No file selected", vbOKOnly, "No file selected"
Exit sub
End If
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'if you hard-cde the path and filename, set your strFileName like this:
' strFileName = "C:\MyPath\MyCSVFile"
Open strFileName For Input As #1
If Err.Number = 0 Then
i = 1
Do While Not EOF(1)
ReDim Preserve arrContacts(2, i)
Input #1, arrContacts(1, i), arrContacts(2, i)
i = i + 1
Loop
Close #1
Else
MsgBox "There was a problem opening the file."
Exit Sub
End If
End Sub
Sub CreateContactItem()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olNewContact As Outlook.ContactItem
Dim olMyParentFolder, olMyContactsFolder As MAPIFolder
Dim i As Integer
On Error Goto errhandler
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olMyParentFolder = olNS.GetDefaultFolder(olFolderContacts)
Set olMyContactsFolder = olMyParentFolder.Folders("Invest")
'Create a contactitem for each array element
For i = LBound(arrContacts) To UBound(arrContacts)
Set olNewContact = olApp.CreateItem(olContactItem)
olNewContact.FullName = arrContacts(1, i)
olNewContact.BusinessTelephoneNumber = arrContacts(2, i)
olNewContact.SaveAs (olMyContactsFolder)
Next i
Set olNewContact = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set olMyParentFolder = Nothing
Set olMyContactsFolder = Nothing
Exit Sub
errhandler:
MsgBox "An error occured." & vbCr & "Error: " & Err.Number & vbCr & "Description: " & _
Err.Description, vbOKOnly + vbCritical, "Error"
Set olNewContact = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set olMyParentFolder = Nothing
Set olMyContactsFolder = Nothing
End Sub
[/vba]