Outlook Export Custom Field to Excel - vba

Question

I have a module that I had used in the past to pull data from my outlook calendar and was putting basically “billing” information into the location field so I didn’t have to do a custom field. Of course that kind of worked until someone sent an invite using location … so I needed to evolve and create a new field. My problem is now of course my VBA must change to use custom fields.
Below is what I have – the “BillingInfo” or the following
.End(xlDown).End(xlUp).Offset(NextRow, 3).Value = ThisAppt.BillingInfo is what is getting flagged.
here is the full ...
' this is the sub to tell outlook what to pull in -
' select the dates as needed
'
Sub GetApptsFromOutlook()
Dim dteStart As Date
Dim dteEnd As Date
dteStart = InputBox("What is the start date?")
dteEnd = InputBox("What is the end date?")
Call GetCalData(dteStart, dteEnd)
End Sub
Private Sub GetCalData(StartDate As Date, Optional EndDate As Date)
' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
' Make sure to reference the Outlook object library before running the code
' End Date is optional, if you want to pull from only one day, use: Call GetCalData("7/14/2008")
' -------------------------------------------------
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim myCalItems As Outlook.Items
Dim ItemstoCheck As Outlook.Items
Dim ThisAppt As Outlook.AppointmentItem
Dim MyItem As Object
Dim StringToCheck As String
Dim MyBook As Excel.Workbook
Dim rngStart As Excel.Range
Dim i As Long
Dim NextRow As Long
' if no end date was specified, then the requestor only wants one day, so set EndDate = StartDate
' this will let us return appts from multiple dates, if the requestor does in fact set an appropriate end date
If EndDate = "12:00:00 AM" Then
EndDate = StartDate
End If
If EndDate < StartDate Then
MsgBox "Those dates seem switched, please check them and try again.", vbInformation
GoTo ExitProc
End If
If EndDate - StartDate > 28 Then
' ask if the requestor wants so much info
If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
GoTo ExitProc
End If
End If
' get or create Outlook object and make sure it exists before continuing
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
GoTo ExitProc
End If
Set olNS = olApp.GetNamespace("MAPI")
Set myCalItems = olNS.GetDefaultFolder(olFolderCalendar).Items
' ------------------------------------------------------------------
' the following code adapted from:
' http://www.outlookcode.com/article.aspx?id=30
'
With myCalItems
.Sort "[Start]", False
.IncludeRecurrences = True
End With
'
StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & " AND [End] <= " & _
Quote(EndDate & " 11:59 PM")
Debug.Print StringToCheck
'
Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
Debug.Print ItemstoCheck.Count
' ------------------------------------------------------------------
If ItemstoCheck.Count > 0 Then
' we found at least one appt
' check if there are actually any items in the collection, otherwise exit
If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc
Set MyBook = Excel.Workbooks.Add
Set rngStart = MyBook.Sheets(1).Range("A1")
With rngStart
.Offset(0, 0).Value = "Start"
.Offset(0, 1).Value = "Duration"
.Offset(0, 2).Value = "Categories"
.Offset(0, 3).Value = "BillingInfo"
.Offset(0, 4).Value = "Subject"
End With
For Each MyItem In ItemstoCheck
If MyItem.Class = olAppointment Then
' MyItem is the appointment or meeting item we want,
' set obj reference to it
Set ThisAppt = MyItem
NextRow = WorksheetFunction.CountA(Range("A:A"))
With rngStart
.End(xlDown).End(xlUp).Offset(NextRow, 0).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
.End(xlDown).End(xlUp).Offset(NextRow, 1).Value = ThisAppt.Duration
.End(xlDown).End(xlUp).Offset(NextRow, 2).Value = ThisAppt.Categories
.End(xlDown).End(xlUp).Offset(NextRow, 3).Value = ThisAppt.BillingInfo
.End(xlDown).End(xlUp).Offset(NextRow, 4).Value = ThisAppt.Subject
If ThisAppt.Categories <> "" Then
.End(xlDown).End(xlUp).Offset(NextRow, 6).Value = ThisAppt.Categories
Else
.End(xlDown).End(xlUp).Offset(NextRow, 6).Value = "n/a"
End If
End With
End If
Next MyItem
' make it pretty
Call Cool_Colors(rngStart)
Else
MsgBox "There are no appointments or meetings during" & _
"the time you specified. Exiting now.", vbCritical
End If
ExitProc:
Set myCalItems = Nothing
Set ItemstoCheck = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set rngStart = Nothing
Set ThisAppt = Nothing
End Sub
Private Function Quote(MyText)
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
Quote = Chr(34) & MyText & Chr(34)
End Function
Private Sub Cool_Colors(rng As Excel.Range)
'
' Lt Blue BG with white letters
'
'
With Range(rng, rng.End(xlToRight))
.Font.ColorIndex = 2
.Font.Bold = True
.HorizontalAlignment = xlCenter
.MergeCells = False
.AutoFilter
.CurrentRegion.Columns.AutoFit
With .Interior
.ColorIndex = 41
.Pattern = xlSolid
End With
End With
End Sub

Answer 1

ThisAppt does not contains BillingInfo directly. You will need to retrieve it through the UserProperties collection like this :
.End(xlDown).End(xlUp).Offset(NextRow, 3).Value = ThisAppt.UserProperties.Item("BillingInfo").Value