Export item values from a folder to Excel

[Michael Jenkin [SBS - MVP]]

Hello,

I have written a small employment system in my public folders.

The aim, store basic employee details in a folder (start date, uniform
issued yes/no) type data.

This works by having a contact folder with a custom form that then fires
off additional forms in another public folder beneith it.

As it is coming to the end of the finaincial year, I now need to provide
a summary of what is stored in the folder.

I have a button that once pressed, enumerates howmany items exist in the
folder (in this case 838 items) and then loops through each item pulling
the relivant data out of the items and into an Excel spread sheet.

Using a next loop, I go through each item however the process always
stalls or stops around 500 items. It never gets to the approx 800 items
in the folder.

It never stops at the same point. Sometimes it gets to 531 items,
somtimes 531 or anywhere inbetween. It looks like outlook is running out
of memory or reaching the maximum number of items it can reference and
then put accross into Excel.

Has anyone got any ideas ?

As I am a cut and paste programmer, there are likely faults with this
code I just don't see (Be gentle with me

This is just the code for the one export routine.

sub cmdexport_click()

Dim objWord
Dim objExcelApp
Dim objExcelBook
Dim objExcelSheets
Dim objExcelSheet
Dim objExcelRange
Dim strRange
Dim lngASC
Dim strASCII
Dim i
Dim lngCount
Dim nms
Dim objFolder
Dim objItems
Dim objItem

Set objWord = CreateObject("Word.Application")
strTemplateDir = objWord.System.PrivateProfileString("",
"HKEY_CURRENT_USER\Software\Microsoft\Office\8.0\Excel\Microsoft Excel",
"DefaultPath") & "\"
strSheet = "expenses.xls"
'strSheet = strTemplateDir & strSheet
strSheet = "C:\"&strSheet

i = 3


lngASCII = 64
Set objExcelApp =
Item.Application.CreateObject("Excel.Application")
objExcelApp.Workbooks.Open(strSheet)
Set objExcelBook = objExcelApp.ActiveWorkbook
Set objExcelSheets = objExcelBook.Worksheets
Set objExcelSheet = objExcelBook.Sheets(1)
objExcelSheet.Activate
objExcelApp.Application.Visible = True

Set MyNameSpace = Application.GetNameSpace("MAPI")
Set MainFolder = MyNameSpace.Folders("Public Folders")
Set SubFolder1 = MainFolder.Folders("All Public Folders")
Set employeeFolder = SubFolder1.Folders("Employee Database")
Set fld = employeeFolder.Folders("Expenses")

Set itms = fld.Items
lngCount = itms.Count

If lngCount = 0 Then
MsgBox "No items to export"
Exit Sub
Else
MsgBox lngCount & " items to export"
End If


For Each itm in itms
i = i + 1



lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If itm.Subject <> "" Then objRange.Value = itm.Subject

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If itm.UserProperties.Find("firstname").value <> "" Then
objRange.Value = itm.UserProperties.Find("firstname").value

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If itm.UserProperties.Find("lastname").value <> "" Then
objRange.Value = itm.UserProperties.Find("lastname").value

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If itm.UserProperties.Find("billdate").value <> "" Then
objRange.Value = itm.UserProperties.Find("billdate").value

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If itm.UserProperties.Find("expensetype").value <> ""
Then objRange.Value = itm.UserProperties.Find("expensetype").value

If itm.UserProperties.Find("expensetype").value ="Car" then

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
if itm.UserProperties.Find("expense").value <> "" Then
objRange.Value = itm.UserProperties.Find("expense").value

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If itm.UserProperties.Find("odometer").value <> "" Then
objRange.Value = itm.UserProperties.Find("odometer").value

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
if itm.UserProperties.Find("fuel").value = "True" Then
objRange.Value = "This is for Fuel"

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
if itm.UserProperties.Find("service").value = "True" Then
objRange.Value = "This is for a Car Service"

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
if itm.UserProperties.Find("Insurance").value = "True"
Then objRange.Value = "This is for Car Insurance"

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
if itm.UserProperties.Find("registration").value = "True"
Then objRange.Value = "This is for Car registration"

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
objRange.Value =
itm.UserProperties.Find("carregistration").value


end if

If itm.UserProperties.Find("expensetype").value ="Phone" then

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
if itm.UserProperties.Find("spent").value <> "" Then
objRange.Value = itm.UserProperties.Find("spent").value

end if

lngASCII = 64

Next
Msgbox "Expense report Generation Completed"
End Sub

 

[Ken Slovak - [MVP - Outlook]]

..NET code huh? Running into a limit on RPC channels probably. Dispose of
your objects in the loop and call the garbage collector and
Marshal.ReleaseCOMObject so those RPC channels aren't held until sometime
after the procedure finishes.

 

[Michael Jenkin [SBS - MVP]]

Thanks Ken however I don't know that I can do this.

The code is using the built in VBA editer in the outlook forms tool.
It is normal VBA called within outlook and not an external app.
I don't beleive it is .Net code.

I agree, the RPC channel issue might be where it falls down.
I am unsure that Outlook has a garbage collector. I can reset the
variables to nothing but that is about it. I don't beleive I can access
Marshal.ReleaseCOMObject from within the VBA interface.

Can you make further suggestions ?

Thanks

 

[Ken Slovak - [MVP - Outlook]]

My mistake.

I don't see anything obvious in your code that would cause it to stop. I'd
suggest running it in the debugger and see where it's stopping and if you
get any errors. That might give some clues.