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

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.

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
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:

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.

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.

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