Exporting Contacts Code

G

Guest

I know this is an old chestnut and I must have spent 2 hours reading
previous posts on this subject without finding a solution.

I have all my contacts grouped into individual folders, and for the
most part switching to a customised view and copy/pasting data into
excel achieves what I need. Until now.

I now need to create a spreadsheet of a selection of contacts from any
particular folder, and export a select number of fields, including some
custom ones. After cannibalising more bits of code then I can start to
describe, and having my head stuck in Sue Mosher's excellent book for a
few days now I still am having problems getting my code to work.

What am trying to do is this:
When the code is launched, it works through the current folder only,
and filters out those contacts that have a custom filed 'IsLiveNow' set
to 'EE', then it exports a selection of fields from the contact to an
excel sheet.

The export bit works, it's the filtering IsLiveNow that is not
working.

Ideally I would like to have a button on the toolbar that opens a box
with options like: select the folder you want to export from, select
the filter to use, etc, then when the user click START it exports the
data for them without having to browse to the fodler in question, but
that can wait for the moment - getting the export working is more
urgent.

here it is:
========================================

Sub FilterToExcel()

Dim objExcelApp
Dim objExcelBook
Dim objExcelSheets
Dim objExcelSheet
Dim objExcelRange
Dim strRange
Dim i
Dim intTotalCount
Dim intDoneCount
Dim objApp
Dim objFolder
Dim objItems
Dim objItem
Dim strFilter

Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Workbooks.Open ("c:\Contacts.xls")
Set objExcelBook = objExcelApp.ActiveWorkbook
Set objExcelSheets = objExcelBook.Worksheets
Set objExcelSheet = objExcelBook.Sheets(1)
objExcelSheet.Activate
objExcelApp.Application.Visible = True

'Get Current Contacts folder

Set objApp = CreateObject("Outlook.Application")
Set objFolder = objapp.ActiveExplorer.CurrentFolder

intTotalCount = objFolder.Items.Count

strFilter = "[UserProperties(""IsLiveNow"") = ""EE"""

For Each objItem In objFolder.Items.Restrict(strFilter)

i = i + 1

strRange = "A" & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If objItem.CompanyName <> "" Then objRange.Value =
objItem.CompanyName

strRange = "B" & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If objItem.MailingAddress <> "" Then objRange.Value =
objItem.MailingAddress

strRange = "C" & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If objItem.CustomerID <> "" Then objRange.Value =
objItem.CustomerID

strRange = "D" & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If objItem.UserProperties("Exit1") <> "" Then objRange.Value =
objItem.UserProperties("Exit1")

strRange = "E" & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If objItem.UserProperties("YearEnd") <> "" Then objRange.Value
= objItem.UserProperties("YearEnd")

intDoneCount = intDoneCount + 1

End If
Next

MsgBox intDoneCount & " of " & intTotalCount & " contacts
exported"

End Sub
===============================================
The reason I can no-longer copy/paste is because several of the fields,
including the mailing address field have the enter (chr(13)) code in
them and it messes everything up.

I hope one of you fine people can show me where I am going wrong...

Many thanks.
 
S

Sue Mosher [MVP-Outlook]

This should be the right filter statement:

strFilter = "[IsLiveNow] = ""EE"""

I personally dislike double quote marks, so I'd so it like this:

strFilter = "[IsLiveNow] = " & Chr(34) & "EE" & Chr(34)

To select a folder, use the Namespace.PickFolder method.

FYI, there is a newsgroup specifically for general Outlook programming issues "down the hall" at microsoft.public.outlook.program_vba or, via web interface, at http://www.microsoft.com/office/community/en-us/default.mspx?dg=microsoft.public.outlook.program_vba

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers


I know this is an old chestnut and I must have spent 2 hours reading
previous posts on this subject without finding a solution.

I have all my contacts grouped into individual folders, and for the
most part switching to a customised view and copy/pasting data into
excel achieves what I need. Until now.

I now need to create a spreadsheet of a selection of contacts from any
particular folder, and export a select number of fields, including some
custom ones. After cannibalising more bits of code then I can start to
describe, and having my head stuck in Sue Mosher's excellent book for a
few days now I still am having problems getting my code to work.

What am trying to do is this:
When the code is launched, it works through the current folder only,
and filters out those contacts that have a custom filed 'IsLiveNow' set
to 'EE', then it exports a selection of fields from the contact to an
excel sheet.

The export bit works, it's the filtering IsLiveNow that is not
working.

Ideally I would like to have a button on the toolbar that opens a box
with options like: select the folder you want to export from, select
the filter to use, etc, then when the user click START it exports the
data for them without having to browse to the fodler in question, but
that can wait for the moment - getting the export working is more
urgent.

here it is:
========================================

Sub FilterToExcel()

Dim objExcelApp
Dim objExcelBook
Dim objExcelSheets
Dim objExcelSheet
Dim objExcelRange
Dim strRange
Dim i
Dim intTotalCount
Dim intDoneCount
Dim objApp
Dim objFolder
Dim objItems
Dim objItem
Dim strFilter

Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Workbooks.Open ("c:\Contacts.xls")
Set objExcelBook = objExcelApp.ActiveWorkbook
Set objExcelSheets = objExcelBook.Worksheets
Set objExcelSheet = objExcelBook.Sheets(1)
objExcelSheet.Activate
objExcelApp.Application.Visible = True

'Get Current Contacts folder

Set objApp = CreateObject("Outlook.Application")
Set objFolder = objapp.ActiveExplorer.CurrentFolder

intTotalCount = objFolder.Items.Count

strFilter = "[UserProperties(""IsLiveNow"") = ""EE"""

For Each objItem In objFolder.Items.Restrict(strFilter)

i = i + 1

strRange = "A" & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If objItem.CompanyName <> "" Then objRange.Value =
objItem.CompanyName

strRange = "B" & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If objItem.MailingAddress <> "" Then objRange.Value =
objItem.MailingAddress

strRange = "C" & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If objItem.CustomerID <> "" Then objRange.Value =
objItem.CustomerID

strRange = "D" & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If objItem.UserProperties("Exit1") <> "" Then objRange.Value =
objItem.UserProperties("Exit1")

strRange = "E" & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If objItem.UserProperties("YearEnd") <> "" Then objRange.Value
= objItem.UserProperties("YearEnd")

intDoneCount = intDoneCount + 1

End If
Next

MsgBox intDoneCount & " of " & intTotalCount & " contacts
exported"

End Sub
===============================================
The reason I can no-longer copy/paste is because several of the fields,
including the mailing address field have the enter (chr(13)) code in
them and it messes everything up.

I hope one of you fine people can show me where I am going wrong...

Many thanks.
Click to expand...
 

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

Speeding up my code 1
Export item values from a folder to Excel 3
Determining Item Methods Available 1
retrieving custom fields causing memory leaks/corruption? 2
Change Value Active X control 3
Macro-Text from word doc paste to excel empty row 1
VBA : import data and replace existing contacts 2
How to add contacts to a public folder 2

Top