Limit Outlook contact import to values with significant data

Posted on 2010-01-12
Medium Priority
Last Modified: 2012-06-27
So, with the code in the related solution below, I would like to limit the import to contacts that have a value in least one of the following entries:


If both entries are blank I want it to skip importing that contact. I've attached a sample import file.
Question by:PaulRKrueger
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
LVL 59

Expert Comment

by:Chris Bottomley
ID: 26293412

Hopefully this'll do it

Dim con 
Dim olkApp 
Dim fldr 
Dim inputFile 
Dim FSO 
Dim contactList 
Dim contactArray 
Dim arrItem 
Dim entryCount 
Dim itemCount 
Dim itemArray 
Dim arrtoFieldLookup() 
Const FilePathandName = "C:\Users\Chris\Experts Exchange\contacts.csv" 
const olFolderContacts = 10 
Const olPublicFoldersAllPublicFolders = 18   
'Delete all contacts  
    For itemCount = olkContacts.Items.count To 1 Step -1  
    Set FSO = CreateObject("scripting.filesystemobject") 
    If FSO.FileExists(FilePathandName) Then 
        Set inputFile = FSO.openTextFile(FilePathandName, 1, True) 
        contactList = inputFile.ReadAll 
        contactArray = Split(contactList, vbcrlf) 
        Set inputFile = Nothing 
        Set inputFile = Nothing 
    End If 
    Set FSO = Nothing 
    For Each arrItem In Split(contactArray(0), ",") 
        itemCount = itemCount + 1 
        ReDim Preserve arrtoFieldLookup(itemCount + 1) 
        Select Case arrItem 
            Case "DisplayName" 
                arrtoFieldLookup(itemCount) = "FullName" 
            Case "department" 
                arrtoFieldLookup(itemCount) = "Department" 
            Case "facsimiletelephonenumber" 
                arrtoFieldLookup(itemCount) = "BusinessFaxNumber" 
            Case "givenname" 
                arrtoFieldLookup(itemCount) = "FirstName" 
            Case "mail" 
                arrtoFieldLookup(itemCount) = "Email1Address" 
            Case "mobile" 
                arrtoFieldLookup(itemCount) = "MobileTelephoneNumber" 
            Case "pager" 
                arrtoFieldLookup(itemCount) = "PagerNumber" 
            Case "physicaldeliveryofficename" 
                arrtoFieldLookup(itemCount) = "BusinessAddressPostOfficeBox" 
            Case "sn" 
                arrtoFieldLookup(itemCount) = "LastName" 
            Case "telephonenumber" 
                arrtoFieldLookup(itemCount) = "PrimaryTelephoneNumber" 
            Case "title" 
                arrtoFieldLookup(itemCount) = "Title" 
            Case "TBD" 
                arrtoFieldLookup(itemCount) = "" 
        End Select 
    Set olkApp = CreateObject("Outlook.Application") 
    For entryCount = LBound(contactArray) + 1 To UBound(contactArray) 
        itemArray = Split(contactArray(entryCount), ",") 
        Set con = olkapp.Session.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("TBC Directory").Folders("TBC Directory").items.Add 
        For itemCount = LBound(itemArray) To UBound(itemArray) 
            'con.ItemProperties(arrtoFieldLookup(itemCount + 1)) = itemArray(itemCount) 
        If itemArray(itemCount)<> "" Then 
                Select Case arrtoFieldLookup(itemCount + 1) 
                    Case "FullName" 
                        con.FullName = itemArray(itemCount) 
                    Case "Department" 
                        con.Department = itemArray(itemCount) 
                    Case "BusinessFaxNumber" 
                        con.BusinessFaxNumber = itemArray(itemCount) 
                    Case "FirstName" 
                        con.FirstName = itemArray(itemCount) 
                    Case "Email1Address" 
                        con.Email1Address = itemArray(itemCount) 
                    Case "MobileTelephoneNumber" 
                        con.MobileTelephoneNumber = itemArray(itemCount) 
                    Case "PagerNumber" 
                        con.PagerNumber = itemArray(itemCount) 
                    Case "BusinessAddressPostOfficeBox" 
                        con.BusinessAddressPostOfficeBox = itemArray(itemCount) 
                    Case "LastName" 
                        con.LastName = itemArray(itemCount) 
                    Case "PrimaryTelephoneNumber" 
                        con.PrimaryTelephoneNumber = itemArray(itemCount) 
                    Case "Title" 
                        con.Title = itemArray(itemCount) 
                    Case "TBD" 
                        con.TBD = itemArray(itemCount) 
                End Select 
            End If 
        If con.PrimaryTelephoneNumber Or con.MobileTelephoneNumber <> "" then con.Save 

Open in new window

LVL 59

Accepted Solution

Chris Bottomley earned 2000 total points
ID: 26293550
In fact it looks as though the ini data at the start is missing recalling I didn't want to delete my contacts when testing, plus a bug ... TCHAHHH and therefore take the script you were using and replace the line 98:


        If con.PrimaryTelephoneNumber <> "" Or con.MobileTelephoneNumber <> "" then con.Save  


Author Comment

ID: 26293678
Brilliant! Thanks a bunch for this. It's working just as I needed.
LVL 59

Expert Comment

by:Chris Bottomley
ID: 26293706
Glad to help ... especially when it's a quick one!


Featured Post

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article will help to fix the below errors for MS Exchange Server 2013 I. Certificate error "name on the security certificate is invalid or does not match the name of the site" II. Out of Office not working III. Make Internal URLs and Externa…
This article describes how to import Lotus Notes Contacts into Outlook 2016, 2013, 2010 and 2007 etc. with a few manual steps. You can easily export and migrate Lotus Notes contacts into Microsoft Outlook without having to use any third party tools.
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…
Suggested Courses

762 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question