Sharing contacts in a workgroup

C

Céline Brien

Hi everybody !
Our workgroup would like to share contacts.
We tried with an Excel file and File, Import from within Outlook.
It work fine !
Now we would like to automate the process.
Does anyone have the macro vba scripting to use from within Outlook to
import contacts in an Excel file ?
Many thanks for your help,
Céline
 
C

Céline Brien

Hi Ken,
Thank you for your answer.
On customimport.htm I found the codes below.
I tried to adapt.
They seem to have to be execute for Excel and I get an error message.
I am serching for codes replacing File, Export and import..., etc.
Codes to execute from Outlook.
Could you just suggest codes to me please !
Céline
----------------
' ExcelDLToContacts
' Listing 24.4
'-------------------------------------------------------------
' Purpose : Create new contacts from data in an Excel Worksheet
'=============================================================
Sub ExcelDLToContacts()
Dim objExcel As Excel.Application
Dim objWB As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim objRange As Excel.Range
Dim objApp As Outlook.Application
Dim objContact As Outlook.ContactItem
Dim intRowCount As Integer
Dim I As Integer
On Error Resume Next

m_blnWeOpenedExcel = False
Set objExcel = GetObject(, "Excel.Application")
If objExcel Is Nothing Then
Set objExcel = CreateObject("Excel.Application")
m_blnWeOpenedExcel = True
End If
On Error GoTo 0
Set objWB = objExcel.Workbooks.Add("C:\Documents and Settings\Céline
Brien\Mes documents\Outlook 2000\Contacts Excel.xls")
Set objWS = objWB.Worksheets(1)
Set objRange = objWS.Range("Data")
intRowCount = objRange.Rows.Count
If intRowCount > 0 Then
Set objApp = CreateObject("Outlook.Application")
For I = 1 To intRowCount
Set objContact = objApp.CreateItem(olContactItem)
With objContact
.Prénom = objRange.Cells(I, 2)
.Nom = objRange.Cells(I, 3)
.Société = objRange.Cells(I, 4)
.Save
End With
Next
End If
objWB.Close False
Call RestoreExcel

Set objExcel = Nothing
Set objWB = Nothing
Set objWS = Nothing
Set objRange = Nothing
Set objApp = Nothing
Set objContact = Nothing
End Sub
 
K

Ken Slovak - [MVP - Outlook]

That's an import procedure. Look at the one on that page for exporting
contact information to Excel.
 
C

Céline Brien

Hi Ken,
Thank for the follow-up.
We don't want to export contacts to Excel.
From within Outlook, we want to import contacts from an Excel file.
From within Outlook, we want to replace the action File, Import, etc. by
a macro.
Many thanks for your help,
Céline
 
K

Ken Slovak - [MVP - Outlook]

The original code you posted earlier in the thread does import contacts from
Excel to Outlook. It can run as an Outlook macro. Obviously you might have
to modify the code for your needs. I don't know what else you want?
 
C

Céline Brien

Hi Ken,
Many, many thanks for your help.
The first time I tried it in Outlook I could'nt even start it.
Now it execute itself almost to the end.
I get an error message on : Call RestoreExcel
The message is :
-----------------------------------
Erreur de compilation
Sub ou Function non definie.
-----------------------------------
Can you help me again ?
Céline


' ExcelDLToContacts
' Listing 24.4
'-------------------------------------------------------------
' Purpose : Create new contacts from data in an Excel Worksheet
'=============================================================
Sub ExcelDLToContacts()
Dim objExcel As Excel.Application
Dim objWB As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim objRange As Excel.Range
Dim objApp As Outlook.Application
Dim objContact As Outlook.ContactItem
Dim intRowCount As Integer
Dim I As Integer
On Error Resume Next

m_blnWeOpenedExcel = False
Set objExcel = GetObject(, "Excel.Application")
If objExcel Is Nothing Then
Set objExcel = CreateObject("Excel.Application")
m_blnWeOpenedExcel = True
End If
On Error GoTo 0
Set objWB = objExcel.Workbooks.Add("C:\Documents and Settings\Céline
Brien\Mes documents\Outlook 2000\Contacts Excel.xls")
Set objWS = objWB.Worksheets(1)
Set objRange = objWS.Range("Data")
intRowCount = objRange.Rows.Count
If intRowCount > 0 Then
Set objApp = CreateObject("Outlook.Application")
For I = 2 To intRowCount
Set objContact = objApp.CreateItem(olContactItem)
With objContact
.Prenom = objRange.Cells(I, 2)
.Nom = objRange.Cells(I, 3)
.Societe = objRange.Cells(I, 4)
.Save
End With
Next
End If
objWB.Close False
Call RestoreExcel

Set objExcel = Nothing
Set objWB = Nothing
Set objWS = Nothing
Set objRange = Nothing
Set objApp = Nothing
Set objContact = Nothing
End Sub
 
K

Ken Slovak - [MVP - Outlook]

Do you have the code for the Sub RestoreExcel included? If not you would get
an error.

From Sue Mosher's excellent book (very, very highly recommended):

Sub RestoreExcel()
Dim objExcel As Excel.Application
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If m_blnWeOpenedExcel Then
objExcel.Quit
Else
objExcel.Visible = True
End If
Set objExcel = Nothing
End Sub

The module level Boolean is used to tell if the code opened Excel or the
user did. To check that you would use GetObject at some early point in your
code and if that failed you'd use CreateObject to get the Excel.Application
object. The logic in the that then sets m_blnWeOpenedExcel.

The purpose of this is to not close down Excel if the user opened it but to
close it if it was opened by your code.
 
C

Céline Brien

Hi Ken,
Thank you again ! With your help I went a step foward.
Now I get an error message on the Save line (see codes below) !
The message is :
-----------------------------------
Erreur de compilation
Sub ou Function non definie.
-----------------------------------
Can you help me again ?
Céline

Sub ExcelDLToContacts()
Dim objExcel As Excel.Application
Dim objWB As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim objRange As Excel.Range
Dim objApp As Outlook.Application
Dim objContact As Outlook.ContactItem
Dim intRowCount As Integer
Dim I As Integer
On Error Resume Next

m_blnWeOpenedExcel = False
Set objExcel = GetObject(, "Excel.Application")
If objExcel Is Nothing Then
Set objExcel = CreateObject("Excel.Application")
m_blnWeOpenedExcel = True
End If
On Error GoTo 0
Set objWB = objExcel.Workbooks.Add("C:\Documents and Settings\Céline
Brien\Mes documents\Outlook 2000\Contacts en Excel.xls")
Set objWS = objWB.Worksheets(1)
Set objRange = objWS.Range("Data")
intRowCount = objRange.Rows.Count
If intRowCount > 0 Then
Set objApp = CreateObject("Outlook.Application")
For I = 1 To intRowCount
Set objContact = objApp.CreateItem(olContactItem)
With objContact
FirstName = objRange.Cells(I, 2)
LastName = objRange.Cells(I, 3)
Compagny = objRange.Cells(I, 4)
Save
End With
Next
End If
objWB.Close False
Call RestoreExcel

Set objExcel = Nothing
Set objWB = Nothing
Set objWS = Nothing
Set objRange = Nothing
Set objApp = Nothing
Set objContact = Nothing
End Sub
Sub RestoreExcel()
Dim objExcel As Excel.Application
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If m_blnWeOpenedExcel Then
objExcel.Quit
Else
objExcel.Visible = True
End If
Set objExcel = Nothing
End Sub
 
K

Ken Slovak - [MVP - Outlook]

Save is within a With block. Do you have a dot in front of Save ( .Save)?
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Import Macro Access Table to Outlook Contacts 3
Sharing contacts in Outlook 1
How Can I create an Outlook Macro to import calendar? 1
Macro to export Outlook contacts 1
sharing contacts 3
Create contacts on startup 0
Import Contacts from a CSV file 1
Sharing BCM contacts within Workgroup, Leads and Projects 5

Top