• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 217
  • Last Modified:

Limit Outlook contact import to values with significant data

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:

telephonenumber
mobile

If both entries are blank I want it to skip importing that contact. I've attached a sample import file.
SampleData2.csv
0
PaulRKrueger
Asked:
PaulRKrueger
  • 3
1 Solution
 
Chris BottomleyCommented:
Paul

Hopefully this'll do it

Chris
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  
        olkContacts.Items(itemCount).Delete  
    Next  
 
    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 
    Else 
        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 
    Next 
     
    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 
        Next 
        If con.PrimaryTelephoneNumber Or con.MobileTelephoneNumber <> "" then con.Save 
    Next

Open in new window

0
 
Chris BottomleyCommented:
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:


        con.Save  
with

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

Chris
0
 
PaulRKruegerAuthor Commented:
Brilliant! Thanks a bunch for this. It's working just as I needed.
0
 
Chris BottomleyCommented:
Glad to help ... especially when it's a quick one!

Chris
0

Featured Post

[Webinar On Demand] Database Backup and Recovery

Does your company store data on premises, off site, in the cloud, or a combination of these? If you answered “yes”, you need a data backup recovery plan that fits each and every platform. Watch now as as Percona teaches us how to build agile data backup recovery plan.

  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now