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

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!
0
altric
Asked:
altric
  • 4
  • 4
1 Solution
 
Chris BottomleyCommented:
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 BottomleyCommented:
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
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

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

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

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