PDA

View Full Version : Automatic Importing



Zepharin
07-27-2004, 09:03 AM
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.

jamescol
07-28-2004, 12:21 AM
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.


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



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

Zepharin
07-28-2004, 12:25 PM
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;

"John Smith","1234567890"
"Jane Smith","6041234567"
"John Doe","9999991111" Thanks for all your help

jamescol
07-28-2004, 04:40 PM
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


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

jamescol
07-28-2004, 08:17 PM
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


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

Zepharin
07-29-2004, 08:52 AM
I tryed to run the module and I got an Error 13: Type Mismatch

jamescol
07-29-2004, 01:39 PM
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

jamescol
07-29-2004, 03:48 PM
Zepharin,
I was able to locate the problem. This sample should work for you.

Let us know.

James


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