I have created a custom form in the CUSTOMER folder in out Public
Folders. The form was created on a contacts form. I am trying to
export the fields on this form to an excel file. So that every contact
that is saved in the folder will be exported to that excel file in the
appropriate column. I have the following code so far:


Function item_click()
Dim objXL
Set objXL = CreateObject("Excel.Application")
objXL.Visible = True
objXL.WorkBooks.Add("C:\EZReader\test.xls")
objXL.Cells(A, 1).Value = Item.Userproperties.find("utility")
objXL.Cells(A, 2).Value = Item.Userproperties.find("CityState")
objXL.Cells(A, 3).Value = Item.Userproperties.find("MainContact")
objXL.Application.Save = "C:\EZReader\test.xls"
objXL.Application.Quit
Set objXL=Nothing
Set MyBook=Nothing
End Function


I have 2 problems with this code:

1. when I save a new contact, nothing happens
2. the code looks as if it will only update each cell (ex. (A,1)) for
each contact and not add additional rows

Please help.

How do I change the following code to include user properties?


Option Explicit

Sub Import_Contacts()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Object
Dim strDummy As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim i As Long

Application.ScreenUpdating = False

'Instantiate the MS Outlook objects.
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.PickFolder

If olFolder Is Nothing Then
GoTo ExitSub
ElseIf olFolder.DefaultItemType olContactItem Then
MsgBox "The selected folder does not contain contacts.",
vbOKOnly
GoTo ExitSub
ElseIf olFolder.Items.Count = 0 Then
MsgBox "No contacts to import.", vbOKOnly
GoTo ExitSub
End If

Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)

'Prepare the targeting worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Company / Private person"
.Cells(1, 2).Value = "Street address"
.Cells(1, 3).Value = "Postal code"
.Cells(1, 4).Value = "City"
.Cells(1, 5).Value = "Contact person"
.Cells(1, 6).Value = "E-mail"
With Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With

Set olColItems = olFolder.Items

'Iterate the collection of contact items.
i = 2
For Each olItem In olColItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.CompanyName, strDummy) 0 Then
Cells(i, 1).Value = .CompanyName
Cells(i, 2).Value = .BusinessAddressStreet
Cells(i, 3).Value = .BusinessAddressPostalCode
Cells(i, 4).Value = .BusinessAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
Else
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .HomeAddressStreet
Cells(i, 3).Value = .HomeAddressPostalCode
Cells(i, 4).Value = .HomeAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End If
End With
i = i + 1
End If
Next olItem


With wsSheet
'Sort the list.
.Range("A2", Cells(2, 6).End(xlDown)).Sort Key1:=Range("A2"), _
Order1:=xlAscending
.Range("A:F").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True

MsgBox "The list has successfully been updated!", vbInformation

ExitSub:
Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub

1) The intrinsic Item object does not support a Click event. If you want code to run when an item is saved, it should go in the Item_Write event handler.

2) You would need to use provide a different value for A, the variable representing the row, for each row you want to fill.

You may also want to consider what you want Outlook to do when you save a contact for the 2nd, 3rd, etc. time.
--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54


"Cass" wrote in message ups.com...
I have created a custom form in the CUSTOMER folder in out Public
Folders. The form was created on a contacts form. I am trying to
export the fields on this form to an excel file. So that every contact
that is saved in the folder will be exported to that excel file in the
appropriate column. I have the following code so far:


Function item_click()
Dim objXL
Set objXL = CreateObject("Excel.Application")
objXL.Visible = True
objXL.WorkBooks.Add("C:\EZReader\test.xls")
objXL.Cells(A, 1).Value = Item.Userproperties.find("utility")
objXL.Cells(A, 2).Value = Item.Userproperties.find("CityState")
objXL.Cells(A, 3).Value = Item.Userproperties.find("MainContact")
objXL.Application.Save = "C:\EZReader\test.xls"
objXL.Application.Quit
Set objXL=Nothing
Set MyBook=Nothing
End Function


I have 2 problems with this code:

1. when I save a new contact, nothing happens
2. the code looks as if it will only update each cell (ex. (A,1)) for
each contact and not add additional rows

Please help.

As in your other post in this thread:

objXL.Cells(A, 1).Value = Item.Userproperties.find("utility")

or simply Item.Userproperties("utility")

See http://outlookcode.com/article.aspx?ID=38

--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54


"Cass" wrote in message oups.com...
How do I change the following code to include user properties?


Option Explicit

Sub Import_Contacts()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Object
Dim strDummy As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim i As Long

Application.ScreenUpdating = False

'Instantiate the MS Outlook objects.
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.PickFolder

If olFolder Is Nothing Then
GoTo ExitSub
ElseIf olFolder.DefaultItemType olContactItem Then
MsgBox "The selected folder does not contain contacts.",
vbOKOnly
GoTo ExitSub
ElseIf olFolder.Items.Count = 0 Then
MsgBox "No contacts to import.", vbOKOnly
GoTo ExitSub
End If

Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)

'Prepare the targeting worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Company / Private person"
.Cells(1, 2).Value = "Street address"
.Cells(1, 3).Value = "Postal code"
.Cells(1, 4).Value = "City"
.Cells(1, 5).Value = "Contact person"
.Cells(1, 6).Value = "E-mail"
With Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With

Set olColItems = olFolder.Items

'Iterate the collection of contact items.
i = 2
For Each olItem In olColItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.CompanyName, strDummy) 0 Then
Cells(i, 1).Value = .CompanyName
Cells(i, 2).Value = .BusinessAddressStreet
Cells(i, 3).Value = .BusinessAddressPostalCode
Cells(i, 4).Value = .BusinessAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
Else
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .HomeAddressStreet
Cells(i, 3).Value = .HomeAddressPostalCode
Cells(i, 4).Value = .HomeAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End If
End With
i = i + 1
End If
Next olItem


With wsSheet
'Sort the list.
.Range("A2", Cells(2, 6).End(xlDown)).Sort Key1:=Range("A2"), _
Order1:=xlAscending
.Range("A:F").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True

MsgBox "The list has successfully been updated!", vbInformation

ExitSub:
Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub

I got it to work by simple changing the code to :



Option Explicit

Sub Import_Contacts()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Object
Dim strDummy As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim i As Long

Application.ScreenUpdating = False

'Instantiate the MS Outlook objects.
Set olApp = Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.PickFolder

If olFolder Is Nothing Then
GoTo ExitSub
ElseIf olFolder.DefaultItemType olContactItem Then
MsgBox "The selected folder does not contain contacts.",
vbOKOnly
GoTo ExitSub
ElseIf olFolder.Items.Count = 0 Then
MsgBox "No contacts to import.", vbOKOnly
GoTo ExitSub
End If

Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)

'Prepare the targeting worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Utility"
.Cells(1, 2).Value = "City, State"
.Cells(1, 3).Value = "Main Contact"
.Cells(1, 4).Value = "City"
.Cells(1, 5).Value = "Contact person"
.Cells(1, 6).Value = "E-mail"
With Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With

Set olColItems = olFolder.Items

'Iterate the collection of contact items.
i = 2
For Each olItem In olColItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.FileAs, strDummy) 0 Then
Cells(i, 1).Value = .UserProperties("Utility")
Cells(i, 2).Value = .UserProperties("CityState")
Cells(i, 3).Value = .UserProperties("MainContact")
Cells(i, 4).Value = .BusinessAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address

Else
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .HomeAddressStreet
Cells(i, 3).Value = .HomeAddressPostalCode
Cells(i, 4).Value = .HomeAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End If
End With
i = i + 1
End If


Next olItem


With wsSheet
'Sort the list.
.Range("A2", Cells(2, 6).End(xlDown)).Sort Key1:=Range("A2"), _
Order1:=xlAscending
.Range("A:F").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True

MsgBox "The list has successfully been updated!", vbInformation

ExitSub:
Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub





However now I get the following message when I run the code:
"a program is trying to access e-mail addresses you have stored in
outlook. do you want to allow this"

And I have to click yes for every single contact in my address book.
Can I stop this error message from appearing?

See http://www.outlookcode.com/article.aspx?ID=52 for your options with regard to the "object model guard" security in Outlook 2000 SP2 and later versions. Rewriting the code as an Outlook VBA routine, upgrading to Outlook 2007, and rewriting to use Redemption would all be viable solutions.

--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54


"Cass" wrote in message ups.com...
I got it to work by simple changing the code to :



Option Explicit

Sub Import_Contacts()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Object
Dim strDummy As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim i As Long

Application.ScreenUpdating = False

'Instantiate the MS Outlook objects.
Set olApp = Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.PickFolder

If olFolder Is Nothing Then
GoTo ExitSub
ElseIf olFolder.DefaultItemType olContactItem Then
MsgBox "The selected folder does not contain contacts.",
vbOKOnly
GoTo ExitSub
ElseIf olFolder.Items.Count = 0 Then
MsgBox "No contacts to import.", vbOKOnly
GoTo ExitSub
End If

Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)

'Prepare the targeting worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Utility"
.Cells(1, 2).Value = "City, State"
.Cells(1, 3).Value = "Main Contact"
.Cells(1, 4).Value = "City"
.Cells(1, 5).Value = "Contact person"
.Cells(1, 6).Value = "E-mail"
With Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With

Set olColItems = olFolder.Items

'Iterate the collection of contact items.
i = 2
For Each olItem In olColItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.FileAs, strDummy) 0 Then
Cells(i, 1).Value = .UserProperties("Utility")
Cells(i, 2).Value = .UserProperties("CityState")
Cells(i, 3).Value = .UserProperties("MainContact")
Cells(i, 4).Value = .BusinessAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address

Else
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .HomeAddressStreet
Cells(i, 3).Value = .HomeAddressPostalCode
Cells(i, 4).Value = .HomeAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End If
End With
i = i + 1
End If


Next olItem


With wsSheet
'Sort the list.
.Range("A2", Cells(2, 6).End(xlDown)).Sort Key1:=Range("A2"), _
Order1:=xlAscending
.Range("A:F").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True

MsgBox "The list has successfully been updated!", vbInformation

ExitSub:
Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub





However now I get the following message when I run the code:
"a program is trying to access e-mail addresses you have stored in
outlook. do you want to allow this"

And I have to click yes for every single contact in my address book.
Can I stop this error message from appearing?

On Sep 27, 10:47 pm, "Sue Mosher [MVP-Outlook]"
wrote:
Seehttp://www.outlookcode.com/article.aspx?ID=52for your options with regard to the "object model guard" security in Outlook 2000 SP2 and later versions. Rewriting the code as an Outlook VBA routine, upgrading to Outlook 2007, and rewriting to use Redemption would all be viable solutions.

--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54



"Cass" wrote in oglegroups.com...
I got it to work by simple changing the code to :

Option Explicit

Sub Import_Contacts()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Object
Dim strDummy As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim i As Long

Application.ScreenUpdating = False

'Instantiate the MS Outlook objects.
Set olApp = Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.PickFolder

If olFolder Is Nothing Then
GoTo ExitSub
ElseIf olFolder.DefaultItemType olContactItem Then
MsgBox "The selected folder does not contain contacts.",
vbOKOnly
GoTo ExitSub
ElseIf olFolder.Items.Count = 0 Then
MsgBox "No contacts to import.", vbOKOnly
GoTo ExitSub
End If

Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)

'Prepare the targeting worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Utility"
.Cells(1, 2).Value = "City, State"
.Cells(1, 3).Value = "Main Contact"
.Cells(1, 4).Value = "City"
.Cells(1, 5).Value = "Contact person"
.Cells(1, 6).Value = "E-mail"
With Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With

Set olColItems = olFolder.Items

'Iterate the collection of contact items.
i = 2
For Each olItem In olColItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.FileAs, strDummy) 0 Then
Cells(i, 1).Value = .UserProperties("Utility")
Cells(i, 2).Value = .UserProperties("CityState")
Cells(i, 3).Value = .UserProperties("MainContact")
Cells(i, 4).Value = .BusinessAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address

Else
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .HomeAddressStreet
Cells(i, 3).Value = .HomeAddressPostalCode
Cells(i, 4).Value = .HomeAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End If
End With
i = i + 1
End If

Next olItem

With wsSheet
'Sort the list.
.Range("A2", Cells(2, 6).End(xlDown)).Sort Key1:=Range("A2"), _
Order1:=xlAscending
.Range("A:F").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True

MsgBox "The list has successfully been updated!", vbInformation

ExitSub:
Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub

However now I get the following message when I run the code:
"a program is trying to access e-mail addresses you have stored in
outlook. do you want to allow this"

And I have to click yes for every single contact in my address book.
Can I stop this error message from appearing?- Hide quoted text -

- Show quoted text -

so can you tell me what these fields are named in outlook because when
I add them to the code i get a debug error

It's the Notes field and the Categories field. The following doesn't
work.

Cells(i, 28).Value = .Notes
Cells(i, 29).Value = .Categories

On Sep 28, 3:48 pm, Cass wrote:
On Sep 27, 10:47 pm, "Sue Mosher [MVP-Outlook]"





wrote:
Seehttp://www.outlookcode.com/article.aspx?ID=52foryour options with regard to the "object model guard" security in Outlook 2000 SP2 and later versions. Rewriting the code as an Outlook VBA routine, upgrading to Outlook 2007, and rewriting to use Redemption would all be viable solutions.

--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54

"Cass" wrote in oglegroups.com...
I got it to work by simple changing the code to :

Option Explicit

Sub Import_Contacts()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Object
Dim strDummy As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim i As Long

Application.ScreenUpdating = False

'Instantiate the MS Outlook objects.
Set olApp = Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.PickFolder

If olFolder Is Nothing Then
GoTo ExitSub
ElseIf olFolder.DefaultItemType olContactItem Then
MsgBox "The selected folder does not contain contacts.",
vbOKOnly
GoTo ExitSub
ElseIf olFolder.Items.Count = 0 Then
MsgBox "No contacts to import.", vbOKOnly
GoTo ExitSub
End If

Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)

'Prepare the targeting worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Utility"
.Cells(1, 2).Value = "City, State"
.Cells(1, 3).Value = "Main Contact"
.Cells(1, 4).Value = "City"
.Cells(1, 5).Value = "Contact person"
.Cells(1, 6).Value = "E-mail"
With Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With

Set olColItems = olFolder.Items

'Iterate the collection of contact items.
i = 2
For Each olItem In olColItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.FileAs, strDummy) 0 Then
Cells(i, 1).Value = .UserProperties("Utility")
Cells(i, 2).Value = .UserProperties("CityState")
Cells(i, 3).Value = .UserProperties("MainContact")
Cells(i, 4).Value = .BusinessAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address

Else
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .HomeAddressStreet
Cells(i, 3).Value = .HomeAddressPostalCode
Cells(i, 4).Value = .HomeAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End If
End With
i = i + 1
End If

Next olItem

With wsSheet
'Sort the list.
.Range("A2", Cells(2, 6).End(xlDown)).Sort Key1:=Range("A2"), _
Order1:=xlAscending
.Range("A:F").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True

MsgBox "The list has successfully been updated!", vbInformation

ExitSub:
Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub

However now I get the following message when I run the code:
"a program is trying to access e-mail addresses you have stored in
outlook. do you want to allow this"

And I have to click yes for every single contact in my address book.
Can I stop this error message from appearing?- Hide quoted text -

- Show quoted text -

so can you tell me what these fields are named in outlook because when
I add them to the code i get a debug error

It's the Notes field and the Categories field. The following doesn't
work.

Cells(i, 28).Value = .Notes
Cells(i, 29).Value = .Categories- Hide quoted text -

- Show quoted text -

Oh also i'm getting the debug error on the Contacts field too. These
are all the default outlook fields but they're not being recognized in
the code. I get this debug error "Run-time error '438': Object doesn't
support this property or method.

so can you tell me what these fields are named in outlook because
when
I add them to the code i get a debug error

It's the Notes field and the Categories field. The following doesn't
work.


Cells(i, 28).Value = .Notes
Cells(i, 29).Value = .Categories

Oh also i'm getting the debug error on the Contacts field too. These
are all the default outlook fields but they're not being recognized in
the code. I get this debug error "Run-time error '438': Object
doesn't
support this property or method.- Hide quoted text -


Also all my dates fields are being exported to Excel with 949998 and
when there is a date in, for example 9/30/2007, in excel it displays
as 39355.3333333333

On Sep 27, 10:47 pm, "Sue Mosher [MVP-Outlook]"
wrote:
Seehttp://www.outlookcode.com/article.aspx?ID=52for your options with regard to the "object model guard" security in Outlook 2000 SP2 and later versions. Rewriting the code as an Outlook VBA routine, upgrading to Outlook 2007, and rewriting to use Redemption would all be viable solutions.

--
Sue Mosher, Outlook MVP
Author of Microsoft Outlook 2007 Programming:
Jumpstart for Power Users and Administrators
http://www.outlookcode.com/article.aspx?id=54



"Cass" wrote in oglegroups.com...
I got it to work by simple changing the code to :

Option Explicit

Sub Import_Contacts()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Object
Dim strDummy As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim i As Long

Application.ScreenUpdating = False

'Instantiate the MS Outlook objects.
Set olApp = Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.PickFolder

If olFolder Is Nothing Then
GoTo ExitSub
ElseIf olFolder.DefaultItemType olContactItem Then
MsgBox "The selected folder does not contain contacts.",
vbOKOnly
GoTo ExitSub
ElseIf olFolder.Items.Count = 0 Then
MsgBox "No contacts to import.", vbOKOnly
GoTo ExitSub
End If

Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)

'Prepare the targeting worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Utility"
.Cells(1, 2).Value = "City, State"
.Cells(1, 3).Value = "Main Contact"
.Cells(1, 4).Value = "City"
.Cells(1, 5).Value = "Contact person"
.Cells(1, 6).Value = "E-mail"
With Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With

Set olColItems = olFolder.Items

'Iterate the collection of contact items.
i = 2
For Each olItem In olColItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.FileAs, strDummy) 0 Then
Cells(i, 1).Value = .UserProperties("Utility")
Cells(i, 2).Value = .UserProperties("CityState")
Cells(i, 3).Value = .UserProperties("MainContact")
Cells(i, 4).Value = .BusinessAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address

Else
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .HomeAddressStreet
Cells(i, 3).Value = .HomeAddressPostalCode
Cells(i, 4).Value = .HomeAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End If
End With
i = i + 1
End If

Next olItem

With wsSheet
'Sort the list.
.Range("A2", Cells(2, 6).End(xlDown)).Sort Key1:=Range("A2"), _
Order1:=xlAscending
.Range("A:F").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True

MsgBox "The list has successfully been updated!", vbInformation

ExitSub:
Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub

However now I get the following message when I run the code:
"a program is trying to access e-mail addresses you have stored in
outlook. do you want to allow this"

And I have to click yes for every single contact in my address book.
Can I stop this error message from appearing?- Hide quoted text -

- Show quoted text -

so can you tell me what these fields are named in outlook because
when
I add them to the code i get a debug error

It's the Notes field and the Categories field. The following doesn't
work.


Cells(i, 28).Value = .Notes
Cells(i, 29).Value = .Categories


Oh also i'm getting the debug error on the Contacts field too. These
are all the default outlook fields but they're not being recognized
in
the code. I get this debug error "Run-time error '438': Object
doesn't
support this property or method.


Also all my dates fields with no dates, which say "None" by default in
the outlook form are being
imported into excel as 1/1/4501. How do I get excel to just leave it
blank?