Consulting

Results 1 to 8 of 8

Thread: Automatic Importing

  1. #1
    VBAX Newbie
    Joined
    Jul 2004
    Posts
    3
    Location

    Question Automatic Importing

    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.

  2. #2
    VBAX Tutor jamescol's Avatar
    Joined
    May 2004
    Location
    Charlotte, NC
    Posts
    251
    Location
    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
    "All that's necessary for evil to triumph is for good men to do nothing."

  3. #3
    VBAX Newbie
    Joined
    Jul 2004
    Posts
    3
    Location
    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

  4. #4
    VBAX Tutor jamescol's Avatar
    Joined
    May 2004
    Location
    Charlotte, NC
    Posts
    251
    Location
    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]
    "All that's necessary for evil to triumph is for good men to do nothing."

  5. #5
    VBAX Tutor jamescol's Avatar
    Joined
    May 2004
    Location
    Charlotte, NC
    Posts
    251
    Location
    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]
    "All that's necessary for evil to triumph is for good men to do nothing."

  6. #6
    VBAX Newbie
    Joined
    Jul 2004
    Posts
    3
    Location
    I tryed to run the module and I got an Error 13: Type Mismatch

  7. #7
    VBAX Tutor jamescol's Avatar
    Joined
    May 2004
    Location
    Charlotte, NC
    Posts
    251
    Location
    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
    "All that's necessary for evil to triumph is for good men to do nothing."

  8. #8
    VBAX Tutor jamescol's Avatar
    Joined
    May 2004
    Location
    Charlotte, NC
    Posts
    251
    Location
    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]
    "All that's necessary for evil to triumph is for good men to do nothing."

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •