J
James
I wrote a macro to extract contact information from a contact based
form and place it in an excel spreadsheet. Along with the standard
fields, I also want info from a couple of custom fields.
There's about 5000 entries........if I only export the standard fields
everything works fine. However if I try and grab info from the 2
custom fields after so many entries Outlook becomes corrupt - by that
I mean the wrong information starts getting returned and if you try
and open up any of the contacts from the folder I'm extracting info
from it tells you that the item can't be opened.
The one field is from a multiselect listbox of type keywords, the
other is a combo box of type text. I can get around 250 entries from
the listbox and around 500 from the combo (in separate tests). Again,
if I only retrieve the standard fields I can extract all 5000 entries
no problem.
I'm running Outlook 2002 SP2.
Most frustrated.
James
----------------------------------
Sub Export()
Dim objExcelApp
Dim objExcelBook
Dim objExcelSheets
Dim objExcelSheet
Dim objExcelRange
Dim objNS
Dim objFolder
Dim objContact
Dim objItems
Dim objRange
Dim objCounter
Dim objControl
On Error Resume Next
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Application.Visible = False
objExcelApp.Application.Workbooks.Add
Set objExcelBook = objExcelApp.ActiveWorkbook
Set objExcelSheets = objExcelBook.Worksheets
Set objExcelSheet = objExcelBook.Sheets(1)
objExcelSheet.Activate
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.Folders("Public Folders").Folders("All Public
Folders").Folders("Sales Contacts")
Set objItems = objFolder.Items
objCounter = 3
objExcelSheet.Range("A1") = "First Name"
objExcelSheet.Range("B1") = "Last Name"
objExcelSheet.Range("C1") = "Company"
objExcelSheet.Range("D1") = "Job Title"
objExcelSheet.Range("E1") = "Street"
objExcelSheet.Range("F1") = "City"
objExcelSheet.Range("G1") = "Province"
objExcelSheet.Range("H1") = "Postal Code"
objExcelSheet.Range("I1") = "Business Phone"
objExcelSheet.Range("J1") = "Fax Number"
objExcelSheet.Range("L1") = "Function"
objExcelApp.Application.Visible = True
For Each Item In objItems
'Set objControl = Item.GetInspector.ModifiedFormPages("Sales
Info").Controls("ListBox1")
Set objRange = objExcelSheet.Range("A" & objCounter)
objRange.Value = Item.FirstName
Set objRange = objExcelSheet.Range("B" & objCounter)
objRange.Value = Item.LastName
Set objRange = objExcelSheet.Range("C" & objCounter)
objRange.Value = Item.CompanyName
Set objRange = objExcelSheet.Range("D" & objCounter)
objRange.Value = Item.JobTitle
Set objRange = objExcelSheet.Range("E" & objCounter)
objRange.Value = Item.BusinessAddressStreet
Set objRange = objExcelSheet.Range("F" & objCounter)
objRange.Value = Item.BusinessAddressCity
Set objRange = objExcelSheet.Range("G" & objCounter)
objRange.Value = Item.BusinessAddressState
Set objRange = objExcelSheet.Range("H" & objCounter)
objRange.Value = Item.BusinessAddressPostalCode
Set objRange = objExcelSheet.Range("I" & objCounter)
objRange.Value = Item.BusinessTelephoneNumber
Set objRange = objExcelSheet.Range("J" & objCounter)
objRange.Value = Item.BusinessFaxNumber
' //This is listbox
' Set objRange = objExcelSheet.Range("L" & objCounter)
' If objControl.Selected(6) = True Then
' objRange.Value = objControl.List(6) //Looking for a
certain entry
' Else
' objRange.Value = "Other"
' End If
' //This is combobox
Set objRange = objExcelSheet.Range("L" & objCounter)
objRange.Value = Item.UserProperties("Function")
objCounter = objCounter + 1
Next
' Clean up variables
Set objExcelApp = Nothing
Set objExcelBook = Nothing
Set objExcelSheets = Nothing
Set objExcelSheet = Nothing
Set objExcelRange = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objContact = Nothing
Set objItems = Nothing
Set objRange = Nothing
Set objCounter = Nothing
Set objControl = Nothing
End Sub
form and place it in an excel spreadsheet. Along with the standard
fields, I also want info from a couple of custom fields.
There's about 5000 entries........if I only export the standard fields
everything works fine. However if I try and grab info from the 2
custom fields after so many entries Outlook becomes corrupt - by that
I mean the wrong information starts getting returned and if you try
and open up any of the contacts from the folder I'm extracting info
from it tells you that the item can't be opened.
The one field is from a multiselect listbox of type keywords, the
other is a combo box of type text. I can get around 250 entries from
the listbox and around 500 from the combo (in separate tests). Again,
if I only retrieve the standard fields I can extract all 5000 entries
no problem.
I'm running Outlook 2002 SP2.
Most frustrated.
James
----------------------------------
Sub Export()
Dim objExcelApp
Dim objExcelBook
Dim objExcelSheets
Dim objExcelSheet
Dim objExcelRange
Dim objNS
Dim objFolder
Dim objContact
Dim objItems
Dim objRange
Dim objCounter
Dim objControl
On Error Resume Next
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Application.Visible = False
objExcelApp.Application.Workbooks.Add
Set objExcelBook = objExcelApp.ActiveWorkbook
Set objExcelSheets = objExcelBook.Worksheets
Set objExcelSheet = objExcelBook.Sheets(1)
objExcelSheet.Activate
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.Folders("Public Folders").Folders("All Public
Folders").Folders("Sales Contacts")
Set objItems = objFolder.Items
objCounter = 3
objExcelSheet.Range("A1") = "First Name"
objExcelSheet.Range("B1") = "Last Name"
objExcelSheet.Range("C1") = "Company"
objExcelSheet.Range("D1") = "Job Title"
objExcelSheet.Range("E1") = "Street"
objExcelSheet.Range("F1") = "City"
objExcelSheet.Range("G1") = "Province"
objExcelSheet.Range("H1") = "Postal Code"
objExcelSheet.Range("I1") = "Business Phone"
objExcelSheet.Range("J1") = "Fax Number"
objExcelSheet.Range("L1") = "Function"
objExcelApp.Application.Visible = True
For Each Item In objItems
'Set objControl = Item.GetInspector.ModifiedFormPages("Sales
Info").Controls("ListBox1")
Set objRange = objExcelSheet.Range("A" & objCounter)
objRange.Value = Item.FirstName
Set objRange = objExcelSheet.Range("B" & objCounter)
objRange.Value = Item.LastName
Set objRange = objExcelSheet.Range("C" & objCounter)
objRange.Value = Item.CompanyName
Set objRange = objExcelSheet.Range("D" & objCounter)
objRange.Value = Item.JobTitle
Set objRange = objExcelSheet.Range("E" & objCounter)
objRange.Value = Item.BusinessAddressStreet
Set objRange = objExcelSheet.Range("F" & objCounter)
objRange.Value = Item.BusinessAddressCity
Set objRange = objExcelSheet.Range("G" & objCounter)
objRange.Value = Item.BusinessAddressState
Set objRange = objExcelSheet.Range("H" & objCounter)
objRange.Value = Item.BusinessAddressPostalCode
Set objRange = objExcelSheet.Range("I" & objCounter)
objRange.Value = Item.BusinessTelephoneNumber
Set objRange = objExcelSheet.Range("J" & objCounter)
objRange.Value = Item.BusinessFaxNumber
' //This is listbox
' Set objRange = objExcelSheet.Range("L" & objCounter)
' If objControl.Selected(6) = True Then
' objRange.Value = objControl.List(6) //Looking for a
certain entry
' Else
' objRange.Value = "Other"
' End If
' //This is combobox
Set objRange = objExcelSheet.Range("L" & objCounter)
objRange.Value = Item.UserProperties("Function")
objCounter = objCounter + 1
Next
' Clean up variables
Set objExcelApp = Nothing
Set objExcelBook = Nothing
Set objExcelSheets = Nothing
Set objExcelSheet = Nothing
Set objExcelRange = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objContact = Nothing
Set objItems = Nothing
Set objRange = Nothing
Set objCounter = Nothing
Set objControl = Nothing
End Sub