Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
?
Solved

Script With EXCEL- Please help

Posted on 2006-05-03
29
Medium Priority
?
255 Views
Last Modified: 2008-01-09

Dear All,

i have the following script, and its for Put Multiple contacts from Excel sheet to Contact folder.

its working fine, without any Problems.

I want only to Do the same step, but with One condetion , is to put them in specific folder - like my other question .

Please Update me .

here is the Script.

i want only to add one thing, that Tell this script to take all the Data From Excel Sheet and put it In Specific Folder under this Folder only " Head-office "

please Help.
==============================================================================
Const olContactItem = 2

Set objOutlook = CreateObject("Outlook.Application")

Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Scripts\contacts.xls")

x = 1

Do Until objExcel.Cells(x,1).Value = ""

    Set objContact = objOutlook.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

    x = x + 1
Loop

objExcel.Quit

0
Comment
Question by:rolamohammed
  • 15
  • 14
29 Comments
 
LVL 44

Expert Comment

by:bruintje
ID: 16594576
Hello rolamohammed,

you could try something like
---------
Dim objNS as Object
Set objNS = objOutlook.GetNamespace("MAPI")
objNS.Folders("Contacts").Folders("Head-office")

'put your own code here

Set myItems = oOlFolder.Items
Set objContact = myItems.Add(olContactItem)
---------

hope this helps a bit
bruintje
0
 

Author Comment

by:rolamohammed
ID: 16594740

is that correct .

under the Brackets, you will find it my code, so do you think, it is correct ?



Dim objNS as Object
Set objNS = objOutlook.GetNamespace("MAPI")
objNS.Folders("Contacts").Folders("Head-office")

====================
Const olContactItem = 2

Set objOutlook = CreateObject("Outlook.Application")

Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Scripts\contacts.xls")

x = 1

Do Until objExcel.Cells(x,1).Value = ""

    Set objContact = objOutlook.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

    x = x + 1
Loop

objExcel.Quit
=======================================


Set myItems = oOlFolder.Items
Set objContact = myItems.Add(olContactItem)
0
 

Author Comment

by:rolamohammed
ID: 16594762

This is the Script, and i have this error :-

Line : 1
Char: 11
Error : Expected end of statement.
Code : 800A0401
Source : Microsoft VBSCRIPT compliation Error .

--------------------------------------------------------------------------

this is the script . where is the Mistake ???????????????????
---------------------------
Dim objNS as Object
Set objNS = objOutlook.GetNamespace("MAPI")
objNS.Folders("Contacts").Folders("Head-office")
Const olContactItem = 2
Set objOutlook = CreateObject("Outlook.Application")
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Scripts\contacts.xls")
x = 1
Do Until objExcel.Cells(x,1).Value = ""

    Set objContact = objOutlook.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

    x = x + 1
Loop

objExcel.Quit
Set myItems = oOlFolder.Items
Set objContact = myItems.Add(olContactItem)
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
LVL 44

Expert Comment

by:bruintje
ID: 16594780
sorry very busy, you need to place the outlook object first like

Dim objNS As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
objNS.Folders("Contacts").Folders ("Head-office")

Const olContactItem = 2


Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Scripts\contacts.xls")

x = 1

Do Until objExcel.Cells(x, 1).Value = ""

    Set objContact = objOutlook.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

    x = x + 1
Loop

objExcel.Quit

Set myItems = oOlFolder.Items
Set objContact = myItems.Add(olContactItem)
0
 

Author Comment

by:rolamohammed
ID: 16594891

Please, its the same error message ,

Please can you help .

Please .
0
 
LVL 44

Expert Comment

by:bruintje
ID: 16594995
ok try, had to declare the folder also my fault

Dim objNS As Object, oOlFolder As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set oOlFolder = objNS.Folders("Contacts").Folders("Head-office")

Const olContactItem = 2


Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Scripts\contacts.xls")

x = 1

Do Until objExcel.Cells(x, 1).Value = ""

    Set objContact = objOutlook.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

    x = x + 1
Loop

objExcel.Quit

Set myItems = oOlFolder.Items
Set objContact = myItems.Add(olContactItem)
0
 
LVL 44

Expert Comment

by:bruintje
ID: 16595146
did you still have an error?
0
 

Author Comment

by:rolamohammed
ID: 16595815

yes, i have the same problem.
here is the script
==============

Dim objNS As Object, oOlFolder As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set oOlFolder = objNS.Folders("Contacts").Folders("Head-office")

Const olContactItem = 2


Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Scripts\contacts.xls")

x = 1

Do Until objExcel.Cells(x, 1).Value = ""

    Set objContact = objOutlook.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

    x = x + 1
Loop

objExcel.Quit

Set myItems = oOlFolder.Items
Set objContact = myItems.Add(olContactItem)

===========
0
 
LVL 44

Expert Comment

by:bruintje
ID: 16595831
could you give a bit more info where is the Head-Office folder located? under contacts or somewhere else
0
 

Author Comment

by:rolamohammed
ID: 16602999
its under the contacts folder .

I hope its clear .
0
 

Author Comment

by:rolamohammed
ID: 16603433
Please urgent Help ,

i am waiting you since yesterday , its not working , please update me .

0
 
LVL 44

Expert Comment

by:bruintje
ID: 16603473
ok there where other problems so i rewrote the script and had it adding one blank contact to the Head-Office folder under my own contacts

Dim objNS, oOlFolder, objOutlook, objWorkbook, x, objContact
Dim myItems

Const olFolderContacts = 10

Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set oOlFolder = objNS.GetDefaultFolder(olFolderContacts).Folders("Head-Office")
Set myItems = oOlFolder.Items

Set objexcel = CreateObject("Excel.Application")
Set objWorkbook = objexcel.Workbooks.Open("C:\Scripts\contacts.xls")

x = 1

Do Until objWorkbook.Sheets(1).Cells(x, 1).Value = ""

    Set objContact = myItems.Add("IPM.Contact.CTXContacts")
    objContact.FullName = objWorkbook.Sheets(1).Cells(x, 1).Value
    objContact.CompanyName = objWorkbook.Sheets(1).Cells(x, 2).Value
    objContact.Email1Address = objWorkbook.Sheets(1).Cells(x, 3).Value
    objContact.Save
    x = x + 1
   
Loop

Set myItems = Nothing
Set oOlFolder = Nothing
Set objNS = Nothing
Set objOutlook = Nothing
Set objContact = Nothing

objWorkbook.Close False
objexcel.Quit
Set objWorkbook = Nothing
Set objexcel = Nothing
0
 

Author Comment

by:rolamohammed
ID: 16603566
its start working, but i have to test and i want to see it with you , please wait with me , i will deploy it in my company today for my IT Manager .

Please do not leave me untill i solve it, please .
0
 
LVL 44

Expert Comment

by:bruintje
ID: 16603576
no problem, but be aware that i'm doing this while i'm working and have other things to attend [not EE related of course :) ]

but just post here and i'll try to stay current
0
 

Author Comment

by:rolamohammed
ID: 16603644

Thanks , for your help .

i tested it, but i have some questions , please do your best to help me.
-----------------------------------------------------

Q1-i want to add All tge Phones Numbers as the following :-

Business-home-Business Fax- Mobile .

and i added like that to the script, but its not working and gives this error message :-

Line : 23
Char : 5
Error: Object doesnot support this Property or method : ' BusinessPhone'
code : 800A01b6

and the line which i add to script was the following :-

objcontact.BusinessPhone= objWorkbook.Sheets(1).Cells(x, 5).Value

but its not working, so Please correct it for me .
and the same error for Add the Phone Home Number , Business Fax , Mobile .
---------------------------------------------------------------------------------------

Q2- I want to add the Addresses Business as well , so Please Add the Script line to it ?
----------------------------------------------------------------------------------------
Q3- i want to add as well the Department , Office, Manager Name & they are located under Details Tape .

please Add the Line of the Script to Add them  if you do not Mind Please .

----------------------------------------------------------------------------------------------

i know i asked you many question, but i promise this will be my final question in this subject, so please do your best to solve them ( 3 questions) and it will work.

Please i am waiting for you .



0
 
LVL 44

Expert Comment

by:bruintje
ID: 16603673
i think this covers them all

          Set objContact = myItems.Add("IPM.Contact.CTXContacts")
          objContact.FullName = objWorkbook.Sheets(1).Cells(x, 1).Value
          objContact.CompanyName = objWorkbook.Sheets(1).Cells(x, 2).Value
          objContact.Email1Address = objWorkbook.Sheets(1).Cells(x, 3).Value
          objContact.BusinessTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 4).Value
          objContact.HomeTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 5).Value
          objContact.BusinessFaxNumber = objWorkbook.Sheets(1).Cells(x, 6).Value
          objContact.MobileTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 7).Value
          objContact.BusinessAddress = objWorkbook.Sheets(1).Cells(x, 8).Value
          objContact.Department = objWorkbook.Sheets(1).Cells(x, 9).Value
          objContact.OfficeLocation = objWorkbook.Sheets(1).Cells(x, 10).Value
          objContact.ManagerName = objWorkbook.Sheets(1).Cells(x, 11).Value

you need to set the correct cell references in excel the Cells(x,x) part

you can also get to these fields yourself (bonus :-))

1. open outlook
2. open the vb editor with ALT+F11
3. now type F2
4. in the search box type ContactItem

this will give you all the properties and methods for the contact but you can walk through the whole outlook object model
0
 

Author Comment

by:rolamohammed
ID: 16603707

Many thanks for you,

its Working , and i want to thank you for your help.

But what do you mean By  :-

" I  can also get to these fields yourself (bonus :-))

1. open outlook
2. open the vb editor with ALT+F11
3. now type F2
4. in the search box type ContactItem

what do you mean i caould not understand you at all.
0
 
LVL 44

Expert Comment

by:bruintje
ID: 16603713
sorry that was meant as an additional comment

you can open the outlook object model to find all these fields yourself for future projects if needed
0
 

Author Comment

by:rolamohammed
ID: 16603870
ok,

but i am trying to access it from shared folder over the Network.

so when i change the Line from :-

Set objWorkbook = objexcel.Workbooks.Open("C:\Scripts\contacts.xls")

to this line :-

Set objWorkbook = objexcel.Workbooks.Open("\\Ho-it-htaguiam\test2")

and i made sure on this folder i gave full control, i found that , i get this error message :-

Line : 12
Char : 1

Error : Unable to Get the Open Property of Workbooks Class.
code : 800A03EC
Source : MS-Excel.

and it gives this Warning message :-

" Cannot be accessed.file may be read-only, or you may be trying to access a read only location. or, the server the document is stored on may not repsonding ".


however, i can access the shared folder and i can open.

so please solve my last question and i will close this case now.

amny thanks for you .


0
 
LVL 44

Expert Comment

by:bruintje
ID: 16604034
ok i've no idea it could be permissions [vbs running under system account or something]

if this was the string you used

("\\Ho-it-htaguiam\test2")

change it to

("\\Ho-it-htaguiam\test2\contacts.xls")

if that does not work then i would try a new script which copies the file to a local destination and deletes when done
---------
Dim objNS, oOlFolder, objOutlook, objWorkbook, x, objContact
Dim myItems, strFilename, fso, aFile

Const olFolderContacts = 10

Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set oOlFolder = objNS.GetDefaultFolder(olFolderContacts).Folders("Head-Office")
Set myItems = oOlFolder.Items

strFilename = "\\Ho-it-htaguiam\test2\contacts.xls"

' copy the file
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile strFilename, "c:\contact.xls",TRUE

Set objexcel = CreateObject("Excel.Application")
Set objWorkbook = objexcel.Workbooks.Open("C:\Scripts\contacts.xls")

x = 1

Do Until objWorkbook.Sheets(1).Cells(x, 1).Value = ""

    Set objContact = myItems.Add("IPM.Contact.CTXContacts")
    objContact.FullName = objWorkbook.Sheets(1).Cells(x, 1).Value
    objContact.CompanyName = objWorkbook.Sheets(1).Cells(x, 2).Value
    objContact.Email1Address = objWorkbook.Sheets(1).Cells(x, 3).Value
    objContact.Save
    x = x + 1
   
Loop

' delete
Set aFile = fso.GetFile("c:\contact.xls")
aFile.Delete
set fso = nothing

Set myItems = Nothing
Set oOlFolder = Nothing
Set objNS = Nothing
Set objOutlook = Nothing
Set objContact = Nothing

objWorkbook.Close False
objexcel.Quit
Set objWorkbook = Nothing
Set objexcel = Nothing
---------
0
 

Author Comment

by:rolamohammed
ID: 16604104

Dear Sir / or Madam .

Really i do not know how to thank you for your great Help.

you are more than Perfect.

its worked .

But my manager asked me for the Final THing which is :-

Can you Please only Add one line to the your final script only , to Add or creat one Folder under Contacts with this name ( Head-Office ), instead of we create this folder manually .

please help us , in this , and this is to confirm you did your best .

many thanks for you .

0
 
LVL 44

Expert Comment

by:bruintje
ID: 16604385
something like

---------
Dim objNS, oOlFolder, objOutlook, objWorkbook, x, objContact
Dim myItems, strFilename, fso, aFile, objExcel
Dim objContacts

Const olFolderContacts = 10

Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set oOlFolder = objNS.GetDefaultFolder(olFolderContacts).Folders.Add("Head-Office", 10)
Set myItems = oOlFolder.Items

strFilename = "\\Ho-it-htaguiam\test2\contacts.xls"

' copy the file
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile strFilename, "c:\contact.xls", True

Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Scripts\contacts.xls")

x = 1

Do Until objWorkbook.Sheets(1).Cells(x, 1).Value = ""

    Set objContact = myItems.Add("IPM.Contact.CTXContacts")
    objContact.FullName = objWorkbook.Sheets(1).Cells(x, 1).Value
    objContact.CompanyName = objWorkbook.Sheets(1).Cells(x, 2).Value
    objContact.Email1Address = objWorkbook.Sheets(1).Cells(x, 3).Value
    objContact.Save
    x = x + 1
   
Loop

' delete
Set aFile = fso.GetFile("c:\contact.xls")
aFile.Delete
Set fso = Nothing

Set myItems = Nothing
Set oOlFolder = Nothing
Set objNS = Nothing
Set objOutlook = Nothing
Set objContact = Nothing

objWorkbook.Close False
objExcel.Quit
Set objWorkbook = Nothing
Set objExcel = Nothing
---------

hopefully you can deliver the project now
0
 

Author Comment

by:rolamohammed
ID: 16604461

thanks , but can i have POP Message appear after it finish & say to the User this for Him:-

" Please be informed that, All of Your Contacts Has been Updated according to Our Standard. if you need any infomation, Please do not hesitiate to Contact us on Ext 307 .
We are here to server you ".

if we can do that , it will be much much much better, and i think i will get bouns , guys, and this is because of you .

please let us finish this as soon as we can to say to the user Bye .

Many thanks for you & i am waiting for POPUP message .

THanks for your Help.

0
 
LVL 44

Accepted Solution

by:
bruintje earned 2000 total points
ID: 16604531
i should really say .....!

but because i'm in a good mood what site are you working on RentACoder?

-----------
Dim objNS, oOlFolder, objOutlook, objWorkbook, x, objContact
Dim myItems, strFilename, fso, aFile, objExcel
Dim objContacts

Const olFolderContacts = 10

Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set oOlFolder = objNS.GetDefaultFolder(olFolderContacts).Folders.Add("Head-Office", 10)
Set myItems = oOlFolder.Items

strFilename = "\\Ho-it-htaguiam\test2\contacts.xls"

' copy the file
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile strFilename, "c:\contact.xls", True

Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Scripts\contacts.xls")

x = 1

Do Until objWorkbook.Sheets(1).Cells(x, 1).Value = ""

    Set objContact = myItems.Add("IPM.Contact.CTXContacts")
    objContact.FullName = objWorkbook.Sheets(1).Cells(x, 1).Value
    objContact.CompanyName = objWorkbook.Sheets(1).Cells(x, 2).Value
    objContact.Email1Address = objWorkbook.Sheets(1).Cells(x, 3).Value
    objContact.Save
    x = x + 1
   
Loop

' delete
Set aFile = fso.GetFile("c:\contact.xls")
aFile.Delete
Set fso = Nothing

Set myItems = Nothing
Set oOlFolder = Nothing
Set objNS = Nothing
Set objOutlook = Nothing
Set objContact = Nothing

objWorkbook.Close False
objExcel.Quit
Set objWorkbook = Nothing
Set objExcel = Nothing

WScript.Echo( "Please be informed that, All of Your Contacts Has been Updated according to Our Standard. if you need any infomation, Please do not hesitiate to Contact us on Ext 307 ." & vbCrLf & "We are here to serve you.")
-----------
0
 

Author Comment

by:rolamohammed
ID: 16604618
Dear Sir / Madam

Many thanks for you ,

I do not know how i can thank you for your great help.

i am not working in Shop, i am working in Small Company, but i am still new to Scripts.

and my manager Promissed me that , if i could do any thing with Scripts, he will give me abouns.

i show him this site, i show him your reply, and he is very happy that , we have like this resoucre so we can be usefule for you .


many many manay thanks for your help and i love you from all of my heart.

My e-mail is ( boma_15@hotmail.com ) or rmt@egysolutions.com ) , please feel free to e-mail me when you ever need .

Rola Mohammed
Egypt
LAND OF Civilization.

0
 
LVL 44

Expert Comment

by:bruintje
ID: 16604677
>>LAND OF Civilization.

Yes you have my vote for that, ok i'm glad i could have helped you

please do me a favor and try to keep Egypt as it is from what i've seen the past few years there are many things destroyed that could've learned us here something about our shared past

Sorry about my suspicious mind but this is the internet and you never know :-)

Hopefully i can see your land once in the future, be sure to have your mail removed from this page by community support else you will be spammed in a few days on those emails since these pages appear on Google
0
 

Author Comment

by:rolamohammed
ID: 16621383
dear sir /  madam ,

i do not have any Problems at all in this Part which is Part A., but only one questio in PART B


thanks for your help.


we deployed the script, that read all the information from Shared folder located on the PC- and create folder on the user him self and all the contacts will be stored on the user Profile.


 PART (  A )  this is the script:-
============================================================================

Dim objNS, oOlFolder, objOutlook, objWorkbook, x, objContact
Dim myItems

Const olFolderContacts = 10

Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set oOlFolder = objNS.GetDefaultFolder(olFolderContacts).Folders.Add("SEMSEM", 10)
Set myItems = oOlFolder.Items

Set objexcel = CreateObject("Excel.Application")
Set objWorkbook = objexcel.Workbooks.Open("\\Ho-it-htaguiam\test2\egypt-2.xls")

x = 1

Do Until objWorkbook.Sheets(1).Cells(x, 1).Value = ""

     Set objContact = myItems.Add("IPM.Contact.CTXContacts")
          objContact.FullName = objWorkbook.Sheets(1).Cells(x, 1).Value
          objContact.CompanyName = objWorkbook.Sheets(1).Cells(x, 2).Value
          objContact.Email1Address = objWorkbook.Sheets(1).Cells(x, 3).Value
          objContact.BusinessTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 4).Value
          objContact.HomeTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 5).Value
          objContact.BusinessFaxNumber = objWorkbook.Sheets(1).Cells(x, 6).Value
          objContact.MobileTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 7).Value
          objContact.BusinessAddress = objWorkbook.Sheets(1).Cells(x, 8).Value
          objContact.Department = objWorkbook.Sheets(1).Cells(x, 9).Value
          objContact.OfficeLocation = objWorkbook.Sheets(1).Cells(x, 10).Value
          objContact.ManagerName = objWorkbook.Sheets(1).Cells(x, 11).Value
       objContact.Save
    x = x + 1
   
Loop

Set myItems = Nothing
Set oOlFolder = Nothing
Set objNS = Nothing
Set objOutlook = Nothing
Set objContact = Nothing

objWorkbook.Close False
objexcel.Quit
Set objWorkbook = Nothing
Set objexcel = Nothing

WScript.Echo( "Say Thanks to  us " & vbCrLf & "We are here to serve you.") .

-------------------------------------------------------------------------------------------------------------------


PART B ):-

now, we deployed to all users, but we think about something.

as you know, every month, we are hiring 20 People.

so i just think about one idea which is :-

in case of any update, only we need to run the script which it need to do the following :-

1- Need to read all the information from Shared Folder.
2- Put all the New contacts from this excel sheet under this shared folder to the user.

but when i run this script , i found that, its display this error message :-

Line: 12
Char :46
Error: Syntax Error
Code : 800A03EA
source : Microsoft VB Script Compilation error

so where could be the Problem ?

here is the script :-
----------------------------------------------------------------------------------------------------------------------------------------

Dim objNS, oOlFolder, objOutlook, objWorkbook, x, objContact
Dim myItems

Const olFolderContacts = 10

Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set oOlFolder = objNS.GetDefaultFolder(olFolderContacts).Folders.Add("SEMSEM", 10)
Set myItems = oOlFolder.Items

Set objexcel = CreateObject("Excel.Application")
Set objWorkbook = objexcel.Workbooks.Open("\\Ho-it-htaguiam\test2\egypt-2.xls")

x = 1

Do Until objWorkbook.Sheets(1).Cells(x, 1).Value = ""

     Set objContact = myItems.Add("IPM.Contact.CTXContacts")
          objContact.FullName = objWorkbook.Sheets(1).Cells(x, 1).Value
          objContact.CompanyName = objWorkbook.Sheets(1).Cells(x, 2).Value
          objContact.Email1Address = objWorkbook.Sheets(1).Cells(x, 3).Value
          objContact.BusinessTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 4).Value
          objContact.HomeTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 5).Value
          objContact.BusinessFaxNumber = objWorkbook.Sheets(1).Cells(x, 6).Value
          objContact.MobileTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 7).Value
          objContact.BusinessAddress = objWorkbook.Sheets(1).Cells(x, 8).Value
          objContact.Department = objWorkbook.Sheets(1).Cells(x, 9).Value
          objContact.OfficeLocation = objWorkbook.Sheets(1).Cells(x, 10).Value
          objContact.ManagerName = objWorkbook.Sheets(1).Cells(x, 11).Value
       objContact.Save
    x = x + 1
   
Loop

Set myItems = Nothing
Set oOlFolder = Nothing
Set objNS = Nothing
Set objOutlook = Nothing
Set objContact = Nothing

objWorkbook.Close False
objexcel.Quit
Set objWorkbook = Nothing
Set objexcel = Nothing

WScript.Echo( "Say Thanks to us ." & vbCrLf & "We are here to serve you.")
----------------------------------------------------------------------------------------------------------------------------------
0
 

Author Comment

by:rolamohammed
ID: 16621415
dear sir /  madam ,

I have this script, that is doing the following :-

1- Create Folder under the Contact Folder in the Personal Folder for MS-OUTLOOK 2003.
2- Copy the Contacts information from Shared folder located on One PC .

we deployed this  script,and we do not have any Problems at all for Part A .

but the Problem is in Part ( B ).


 PART (  A )  this is the script:-
============================================================================

Dim objNS, oOlFolder, objOutlook, objWorkbook, x, objContact
Dim myItems

Const olFolderContacts = 10

Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set oOlFolder = objNS.GetDefaultFolder(olFolderContacts).Folders.Add("SEMSEM", 10)
Set myItems = oOlFolder.Items

Set objexcel = CreateObject("Excel.Application")
Set objWorkbook = objexcel.Workbooks.Open("\\Ho-it-htaguiam\test2\egypt-2.xls")

x = 1

Do Until objWorkbook.Sheets(1).Cells(x, 1).Value = ""

     Set objContact = myItems.Add("IPM.Contact.CTXContacts")
          objContact.FullName = objWorkbook.Sheets(1).Cells(x, 1).Value
          objContact.CompanyName = objWorkbook.Sheets(1).Cells(x, 2).Value
          objContact.Email1Address = objWorkbook.Sheets(1).Cells(x, 3).Value
          objContact.BusinessTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 4).Value
          objContact.HomeTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 5).Value
          objContact.BusinessFaxNumber = objWorkbook.Sheets(1).Cells(x, 6).Value
          objContact.MobileTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 7).Value
          objContact.BusinessAddress = objWorkbook.Sheets(1).Cells(x, 8).Value
          objContact.Department = objWorkbook.Sheets(1).Cells(x, 9).Value
          objContact.OfficeLocation = objWorkbook.Sheets(1).Cells(x, 10).Value
          objContact.ManagerName = objWorkbook.Sheets(1).Cells(x, 11).Value
       objContact.Save
    x = x + 1
   
Loop

Set myItems = Nothing
Set oOlFolder = Nothing
Set objNS = Nothing
Set objOutlook = Nothing
Set objContact = Nothing

objWorkbook.Close False
objexcel.Quit
Set objWorkbook = Nothing
Set objexcel = Nothing

WScript.Echo( "Say Thanks to  us " & vbCrLf & "We are here to serve you.") .

-------------------------------------------------------------------------------------------------------------------


PART B ):-

Now, we are hiring every month 20 Persons.

so we need to update all the users as well with the same configurations for them - E-mails, Numbers, & So on ...

so , i change the first line in script, so instead of creating the folder, it will check only the folder which has been created by the script in PART A and start doing its work.

but when i run this script , i found that, its display this error message :-

Line: 12
Char :46
Error: Syntax Error
Code : 800A03EA
source : Microsoft VB Script Compilation error

so where could be the Problem ?
 
here is the script :- ( PART B ).
----------------------------------------------------------------------------------------------------------------------------------------

Dim objNS, oOlFolder, objOutlook, objWorkbook, x, objContact
Dim myItems

Const olFolderContacts = 10

Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set oOlFolder = objNS.GetDefaultFolder(olFolderContacts).Folders.Add("SEMSEM", 10)
Set myItems = oOlFolder.Items

Set objexcel = CreateObject("Excel.Application")
Set objWorkbook = objexcel.Workbooks.Open("\\Ho-it-htaguiam\test2\egypt-2.xls")

x = 1

Do Until objWorkbook.Sheets(1).Cells(x, 1).Value = ""

     Set objContact = myItems.Add("IPM.Contact.CTXContacts")
          objContact.FullName = objWorkbook.Sheets(1).Cells(x, 1).Value
          objContact.CompanyName = objWorkbook.Sheets(1).Cells(x, 2).Value
          objContact.Email1Address = objWorkbook.Sheets(1).Cells(x, 3).Value
          objContact.BusinessTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 4).Value
          objContact.HomeTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 5).Value
          objContact.BusinessFaxNumber = objWorkbook.Sheets(1).Cells(x, 6).Value
          objContact.MobileTelephoneNumber = objWorkbook.Sheets(1).Cells(x, 7).Value
          objContact.BusinessAddress = objWorkbook.Sheets(1).Cells(x, 8).Value
          objContact.Department = objWorkbook.Sheets(1).Cells(x, 9).Value
          objContact.OfficeLocation = objWorkbook.Sheets(1).Cells(x, 10).Value
          objContact.ManagerName = objWorkbook.Sheets(1).Cells(x, 11).Value
       objContact.Save
    x = x + 1
   
Loop

Set myItems = Nothing
Set oOlFolder = Nothing
Set objNS = Nothing
Set objOutlook = Nothing
Set objContact = Nothing

objWorkbook.Close False
objexcel.Quit
Set objWorkbook = Nothing
Set objexcel = Nothing

WScript.Echo( "Say Thanks to us ." & vbCrLf & "We are here to serve you.")
0
 
LVL 44

Expert Comment

by:bruintje
ID: 16622340
Dear Rola,

For a followup question you better ask a new question with a pointer this one, that will give more people the chance to lend you a hand.

I've seen you already asked a new one :)

Take Care
Brian
0

Featured Post

Hire Technology Freelancers with Gigs

Work with freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely, and get projects done right.

Question has a verified solution.

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

I’ve seen a number of people looking for examples of how to access web services from VB6.  I’ve been using a test harness I built in VB6 (using many resources I found online) that I use for small projects to work out how to communicate with web serv…
Background What I'm presenting in this article is the result of 2 conditions in my work area: We have a SQL Server production environment but no development or test environment; andWe have an MS Access front end using tables in SQL Server but we a…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…
Suggested Courses
Course of the Month15 days, 23 hours left to enroll

581 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