I am trying to do a simple import of items that are in an outlook
public folder to an excel spreadsheet.

This seems to work well but contains some major memory issues. I have
over 1000 OL items that I need to import to my spreadsheet but it
seems to hang up around 150 and I get all kinds of memory errors,
mainly in outlook.

Does anyone know of an easier way to do this or any suggestions on
where my code is having my ram for lunch.

I have watched this code run with the task manager up and it is eating
approx. 1Meg for every 2 OLitem.

Please help.

Tony


'THIS IS THE VBA CODE THAT I AM USING IN EXCEL.

Option Explicit

Dim myOlApp
Dim MyNameSpace As NameSpace
Dim PublicFolders As MAPIFolder
Dim AllPublicFolders As MAPIFolder
Dim dFolders As MAPIFolder
Dim XRef As MAPIFolder
Dim Items As Outlook.Items
Dim XRefItem As Object


Private Sub CommandButton1_Click()

Set myOlApp = CreateObject("Outlook.Application")
Set MyNameSpace = myOlApp.GetNamespace("MAPI")
Set PublicFolders = MyNameSpace.Folders("Public Folders")
Set AllPublicFolders = PublicFolders.Folders("All Public Folders")
Set dFolders = AllPublicFolders.Folders("Department")
Set XRef = dFolders.Folders("XRef")
Set Items = XRef.Items

'Set up Header Row and Column Widths
Range("A1:N1").Value = Array("SampleNum", "Date", "Customer",
"CustDesc", "Description", "StockNum", "PartNum", "Width", "Warp",
"Fill", "Price", "10DigitCode", "SpecialCmts", "EntryID")

Range("A1,B1,G1,H1,I1,J1,K1,L1").HorizontalAlignme nt = xlCenter
Range("A1,B1,G1,H1,I1,J1,K1,L1").Font.Bold = True

Range("C1,D1,E1,F1,M1,N1").HorizontalAlignment = xlLeft
Range("C1,D1,E1,F1,M1,N1").Font.Bold = True

Range("I:J").Select
Selection.ColumnWidth = 5

Range("A:B,G:H,K:L").Select
Selection.ColumnWidth = 10

Range("C:D,F:F").Select
Selection.ColumnWidth = 20

Range("E:E,M:M").Select
Selection.ColumnWidth = 40

Range("N:N").Select
Selection.ColumnWidth = 30
'Selection.EntireColumn.Hidden = True

'Return here to get ready for data import
Range("A1").Select

'Import data from Outlook

Dim x As Integer
x = 1

'Loop through each field in each record
For Each XRefItem In Items

ActiveCell.Offset(x) =
XRefPage.GetInspector.ModifiedFormPages("Cross
Reference").Controls("SampleNum")
ActiveCell.Offset(x, 1) =
XRefPage.GetInspector.ModifiedFormPages("Cross
Reference").Controls("Date")
ActiveCell.Offset(x, 2) =
XRefPage.GetInspector.ModifiedFormPages("Cross
Reference").Controls("Customer")
ActiveCell.Offset(x, 3) =
XRefPage.GetInspector.ModifiedFormPages("Cross
Reference").Controls("CustDescription")
ActiveCell.Offset(x, 4) =
XRefItem.GetInspector.ModifiedFormPages("Cross
Reference").Controls("Description")
ActiveCell.Offset(x, 5) =
XRefItem.GetInspector.ModifiedFormPages("Cross
Reference").Controls("StockNum")
ActiveCell.Offset(x, 6) =
XRefItem.GetInspector.ModifiedFormPages("Cross
Reference").Controls("PartNum")
ActiveCell.Offset(x, 7) =
XRefItem.GetInspector.ModifiedFormPages("Cross
Reference").Controls("Width")
ActiveCell.Offset(x, 8) =
XRefItem.GetInspector.ModifiedFormPages("Cross
Reference").Controls("Warp")
ActiveCell.Offset(x, 9) =
XRefItem.GetInspector.ModifiedFormPages("Cross
Reference").Controls("Fill")
ActiveCell.Offset(x, 10) =
XRefItem.GetInspector.ModifiedFormPages("Cross
Reference").Controls("Price")
ActiveCell.Offset(x, 11) =
XRefItem.GetInspector.ModifiedFormPages("Cross
Reference").Controls("10DigitCode")
ActiveCell.Offset(x, 12) =
XRefItem.GetInspector.ModifiedFormPages("Cross
Reference").Controls("SpecialCmts")
ActiveCell.Offset(x, 13) = XRefItem.EntryID
x = x + 1

Next

Set XRefItem = Nothing
Set Items = Nothing
Set XRef = Nothing
Set dFolders = Nothing
Set AllPublicFolders = Nothing
Set PublicFolders = Nothing
Set MyNameSpace = Nothing
Set myOlApp = Nothing

End Sub

Private Sub CommandButton2_Click()

Me.Hide

End Sub