VBscipt to add new contact in to subfolder of Contact in Outlook

Hi there,

I was trying to add new contact into a subfolder in Outlook Contact i.e "Personal Contact" with the following code:


   Const InpFile = "C:\contacts.csv"
   Const olContactItem = 2
   Const olFolderContacts = 10
   Dim objOutl, objContact, objExcel, objWorkbook

   Set objOutl = CreateObject("Outlook.Application")
   Set objExcel = CreateObject("Excel.Application")
   Set objWorkbook = objExcel.Workbooks.Open(inpFile)
   
   Set objNamespace = objOutl.GetNamespace("MAPI")
   Set folContacts = objNamespace.GetDefaultFolder(olFolderContacts)
   Set folContacts2 = folContacts.Folders("Personal Contact")
   set colContacts = folContacts2.items
   
   x = 2
 
   found=0
   'wscript.echo colContacts
   Do Until objExcel.Cells(x,1).Value = ""
   
   For Each objContact In colContacts
    'Wscript.Echo objExcel.cells(x,1)
    If objContact.FullName = objExcel.cells(X,1) then
         found = found + 1
         'Wscript.Echo "Found match record."
         exit for
    End If
   Next
   'Wscript.Echo found
   If found < 1 then
     Set objContact = objOutl.CreateItem(olContactItem)
     objContact.FullName = objExcel.Cells(x,1).Value
     objContact.CompanyName = objExcel.Cells(x,2).Value
     objContact.Email1Address = objExcel.Cells(x,3).Value
     objContact.Save
     'Wscript.Echo found
     
   End If
    x = x + 1
  found = 0
Loop
ObjWorkbook.close
objExcel.Quit

However, all those contact in contacts.csv file were imported to root folder of Contact in the Outlook and not "Personal Contact" folder.

Anyone pls enlighten me.... thank you!
altricAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Chris BottomleySoftware Quality Lead EngineerCommented:
Hello altric,

I use a function to add a sub ... try the following change for your block:

Chris



Regards,
Chris
   Const InpFile = "C:\contacts.csv"
   Const olContactItem = 2
   Const olFolderContacts = 10
   Dim objOutl, objContact, objExcel, objWorkbook 
   Set objOutl = CreateObject("Outlook.Application")
   Set objExcel = CreateObject("Excel.Application")
   Set objWorkbook = objExcel.Workbooks.Open(inpFile)
   
   Set objNamespace = objOutl.GetNamespace("MAPI")
   Set folContacts = objNamespace.GetDefaultFolder(olFolderContacts)
'   Set folContacts2 = folContacts.Folders("Personal Contact")
    Set folContacts2 = nav2Folder(folContacts.folderpath & "\" & "Contacts2")
    set colContacts = folContacts2.items
   x = 2
 
   found=0
   'wscript.echo colContacts
   Do Until objExcel.Cells(x,1).Value = ""
   
   For Each objContact In colContacts
    'Wscript.Echo objExcel.cells(x,1)
    If objContact.FullName = objExcel.cells(X,1) then
         found = found + 1
         'Wscript.Echo "Found match record."
         exit for
    End If
   Next
   'Wscript.Echo found
   If found < 1 then
     Set objContact = objOutl.CreateItem(olContactItem)
     objContact.FullName = objExcel.Cells(x,1).Value
     objContact.CompanyName = objExcel.Cells(x,2).Value
     objContact.Email1Address = objExcel.Cells(x,3).Value
     objContact.Save
     'Wscript.Echo found
     
   End If
    x = x + 1
  found = 0
Loop
ObjWorkbook.close
objExcel.Quit 
 

'Add this function
Public Function nav2Folder(foldername As String) As Outlook.MAPIFolder
'    Set fldr = nav2Folder("\\Personal Folders\Inbox\Inbox2")
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olfldr As Outlook.folders
Dim reqdFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNS.folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                reqdFolder.folders.Add (arrFolders(nestCount))
                Set olfldr = reqdFolder.folders
                Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            End If
        Else
        End If
    Next
    Set nav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNS = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

0
altricAuthor Commented:
Thanks for the response.

I tried the code but it gives me an error:

Script: C:\test.vbs
Line: 46
Error: Expected ')
Code: 800A03EE
Source: Microsoft VBScript compilation error

Futhermore, my original code is vbs and yours seem to be VBA code.  Can both type of codes mixed together when I executed them in a file called test.vbs?

Please advise.

Thank you.
0
Chris BottomleySoftware Quality Lead EngineerCommented:
First off apologies I will reform as VBS.  replace the function with the snippet

Second the line errormeans nothing without a full copy of the script from and up to that line number, can you provide?

Chris
Public Function nav2Folder(foldername)
Dim olApp
Dim olNS
Dim olfldr
Dim reqdFolder
Dim arrFolders
Dim nestCount
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders = Split(foldername, "\")
    Set olApp = createobject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNS.folders.item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.item(arrFolders(nestCount))
            If reqdFolder <> olfldr.item(arrFolders(nestCount)) Then
                reqdFolder.folders.Add (arrFolders(nestCount))
                Set olfldr = reqdFolder.folders
                Set reqdFolder = olfldr.item(arrFolders(nestCount))
            End If
        Else
        End If
    Next
    Set nav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNS = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

0
Cloud Class® Course: Microsoft Office 2010

This course will introduce you to the interfaces and features of Microsoft Office 2010 Word, Excel, PowerPoint, Outlook, and Access. You will learn about the features that are shared between all products in the Office suite, as well as the new features that are product specific.

altricAuthor Commented:
Thanks for the rectification.  

Previous error no longer appears but the contacts from .csv file were imported to the root of the Contacts folder in Outlook and not in the "Personal Contact" subfolder.

Tree Structure:
Outlook
 |- Contacts (root)
    |- Personal Contact (subfolder)

Here is the full code:

 Const InpFile = "C:\contacts.csv"
   Const olContactItem = 2
   Const olFolderContacts = 10
   Dim objOutl, objContact, objExcel, objWorkbook
   Set objOutl = CreateObject("Outlook.Application")
   Set objExcel = CreateObject("Excel.Application")
   Set objWorkbook = objExcel.Workbooks.Open(inpFile)
   
   Set objNamespace = objOutl.GetNamespace("MAPI")
   Set folContacts = objNamespace.GetDefaultFolder(olFolderContacts)
   Set folContacts2 = nav2Folder(folContacts.folderpath & "\" & "Personal Contact")
   set colContacts = folContacts2.items
   x = 2
   
   found=0

   Do Until objExcel.Cells(x,1).Value = ""
   
   For Each objContact In colContacts
    'Wscript.Echo objExcel.cells(x,1)
    If objContact.FullName = objExcel.cells(X,1) then
         found = found + 1
         exit for
    End If
   Next

   If found < 1 then
     Set objContact = objOutl.CreateItem(olContactItem)
     objContact.FullName = objExcel.Cells(x,1).Value
     objContact.CompanyName = objExcel.Cells(x,2).Value
     objContact.Email1Address = objExcel.Cells(x,3).Value
     objContact.Save
     'Wscript.Echo found
     
   End If
    x = x + 1
  found = 0
Loop
ObjWorkbook.close
objExcel.Quit
 
Public Function nav2Folder(foldername)
Dim olApp
Dim olNS
Dim olfldr
Dim reqdFolder
Dim arrFolders
Dim nestCount
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders = Split(foldername, "\")
    Set olApp = createobject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNS.folders.item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.item(arrFolders(nestCount))
            If reqdFolder <> olfldr.item(arrFolders(nestCount)) Then
                reqdFolder.folders.Add (arrFolders(nestCount))
                Set olfldr = reqdFolder.folders
                Set reqdFolder = olfldr.item(arrFolders(nestCount))
            End If
        Else
        End If
    Next
    Set nav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNS = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Please advise.

Thank you.
0
Chris BottomleySoftware Quality Lead EngineerCommented:
I presume you are referring to the block:

   If found < 1 then
     Set objContact = objOutl.CreateItem(olContactItem)
     objContact.FullName = objExcel.Cells(x,1).Value
     objContact.CompanyName = objExcel.Cells(x,2).Value
     objContact.Email1Address = objExcel.Cells(x,3).Value
     objContact.Save
     'Wscript.Echo found
     
   End If

IN this case you are creating  contact BUT not putting it into the subfolder ... they are created in teh default folder.  Use

objContact.Move folContacts2

Chris
Const InpFile = "C:\contacts.csv"
   Const olContactItem = 2
   Const olFolderContacts = 10
   Dim objOutl, objContact, objExcel, objWorkbook 
   Set objOutl = CreateObject("Outlook.Application")
   Set objExcel = CreateObject("Excel.Application")
   Set objWorkbook = objExcel.Workbooks.Open(inpFile)
   
   Set objNamespace = objOutl.GetNamespace("MAPI")
   Set folContacts = objNamespace.GetDefaultFolder(olFolderContacts)
   Set folContacts2 = nav2Folder(folContacts.folderpath & "\" & "Personal Contact")
   set colContacts = folContacts2.items
   x = 2
   
   found=0
 
   Do Until objExcel.Cells(x,1).Value = ""
   
   For Each objContact In colContacts
    'Wscript.Echo objExcel.cells(x,1)
    If objContact.FullName = objExcel.cells(X,1) then
         found = found + 1
         exit for
    End If
   Next
 
   If found < 1 then
     Set objContact = objOutl.CreateItem(olContactItem)
     objContact.FullName = objExcel.Cells(x,1).Value
     objContact.CompanyName = objExcel.Cells(x,2).Value
     objContact.Email1Address = objExcel.Cells(x,3).Value
     objContact.Save
     objContact.Move folContacts2
     'Wscript.Echo found
     
   End If
    x = x + 1
  found = 0
Loop
ObjWorkbook.close
objExcel.Quit 
 
Public Function nav2Folder(foldername)
Dim olApp
Dim olNS
Dim olfldr
Dim reqdFolder
Dim arrFolders
Dim nestCount
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders = Split(foldername, "\")
    Set olApp = createobject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNS.folders.item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.folders
            Set reqdFolder = olfldr.item(arrFolders(nestCount))
            If reqdFolder <> olfldr.item(arrFolders(nestCount)) Then
                reqdFolder.folders.Add (arrFolders(nestCount))
                Set olfldr = reqdFolder.folders
                Set reqdFolder = olfldr.item(arrFolders(nestCount))
            End If
        Else
        End If
    Next
    Set nav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNS = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
altricAuthor Commented:
It works!! But just curious, is it possible to save the contact items directly into subfolder without using the MOVE command?

Please advise.

Thank you.
0
Chris BottomleySoftware Quality Lead EngineerCommented:
I'm not sure in all honesty ... the create / move is soooo much easier.  I did try it direct once and cannot recall if it worked or not.  At the time it was such a palaver I settled for easy.

Chris
0
altricAuthor Commented:
Anyway, thanks a lot.  You deserve the effort that you have put...CheerS!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.