Export Outlook custom forms fields to excel

newoay

New Member
Outlook version
Outlook 2007
Email Account
Exchange Server
Hi all,

I have a created a Custom Form in Outlook and would like to populate the fields to Excel. I am expecting to receive many such Custom Form emails so to automate the fields to populate to Excel would really help alot.
upload_2015-10-13_18-32-26.png

They are Listbox1, Listbox2, and Combobox1 respectively.
I've obtained a sample VBA code online that allows me to do the same to other fields but I've no idea how to utilise it to populate Custom Form fields. The code is below.

OptionExplicit
'This Code is Downloaded from OfficeTricks.com
'Visit this site for more such Free Code
Sub Download_Outlook_Mail_To_Excel()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim iRow AsInteger, oRow AsInteger
Dim MailBoxName AsString, Pst_Folder_Name AsString

'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
MailBoxName = "MailBox Name"
'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
Pst_Folder_Name = "Folder Name"'Sample "Inbox" or "Sent Items"
'To directly a Folder at a high level
'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)

'To access a main folder or a subfolder (level-1)
ForEach Folder In Outlook.Session.Folders(MailBoxName).Folders
If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) ThenGoTo Label_Folder_Found
ForEach sFolders In Folder.Folders
If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
Set Folder = sFolders
GoTo Label_Folder_Found
EndIf
Next sFolders
Next Folder
Label_Folder_Found:
If Folder.Name = ""Then
MsgBox "Invalid Data in Input"
GoTo End_Lbl1:
EndIf
'Read Through each Mail and export the details to Excel for Email Archival
ThisWorkbook.Sheets(1).Activate
Folder.Items.Sort "Received"

'Insert Column Headers
ThisWorkbook.Sheets(1).Cells(1, 1) = "Sender"
ThisWorkbook.Sheets(1).Cells(1, 2) = "Subject"
ThisWorkbook.Sheets(1).Cells(1, 3) = "Date"
ThisWorkbook.Sheets(1).Cells(1, 4) = "Size"
ThisWorkbook.Sheets(1).Cells(1, 5) = "EmailID"
'ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"

'Export eMail Data from PST Folder
oRow = 1
For iRow = 1 To Folder.Items.Count
'If condition to import mails received in last 60 days
'To import all emails, comment or remove this IF condition
If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then
oRow = oRow + 1
ThisWorkbook.Sheets(1).Cells(oRow, 1).Select
ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
ThisWorkbook.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
ThisWorkbook.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size
ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
'ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
EndIf
Next iRow
MsgBox "Outlook Mails Extracted to Excel"
Set Folder = Nothing
Set sFolders = Nothing

End_Lbl1:
EndSub
 
Top