Outlook Macro Export Fields To Named Excel Workbook

Hi,

Do you wish the existing Microsoft Excel workbook to retrieve the data (with the Visual Basic for Applications code to do this residing within the workbook), or for Outlook session to open the workbook, transfer the data, save, & then close the workbook?

Will multiple parties be undertaking this task (potentially) concurrently, or will a single party be responsible for transferring the contents from their Outlook session to the workbook?

BFN,

fp.

BFN,

Yes, the Excel workbook should retrieve the data.

To keep this as simple as possible, one person, at one time, will open the existing workbook that holds the macro, open the email account, and run  the macro to extract the information. But that person will change periodically.

Background: We are required to have a 'form', approval, and tracking, for approximately 500 new transactions each week. We developed an Excel form with a button that creates an email with a reference no. in the subject line. We need to extract the reference no. (and other fields) to compare to reference no.s in a report of all possible transactions, to see what was approved. The comparison part is a separate macro and we should not have a problem with its development. The email account is a separate account and only receives the approval 'forms'.

Your assistance is appreciated.

Tosagua

So you have data in MS-Excel that is used in the subject line of an e-mail created by the Excel workbook.

You now wish to re-read the information back into a(nother) workbook.

Why not just store the data used to create the e-mails at the time of creation & use that list instead of having to read from an MS-Outlook session?

Hi, Tosagua.

Try this.  It's a knockoff of Revision 2 of the code I wrote for this post on my blog.

'On the next line change the value to True if you want each export to go on a new sheet.
Const EXPORT_NEWSHEET = False
Const MACRO_NAME = "Export Messages to Excel"

Sub ExportController()
    'Add as many exports as you need. Each export is controlled by a line like the following
    'The format of the command is ExportMessagesToExcel "Path to Workbook", Outlook folder
    ExportMessagesToExcel "C:\Tosagua.xlsx", Session.GetDefaultFolder(olFolderInbox)
    MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Sub ExportMessagesToExcel(strFilename As String, olkFld As Outlook.MAPIFolder)
    Dim olkMsg As Object, _
        olkRcp As Outlook.RECIPIENT, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVer As Integer, _
        strToName As String, _
        strToAddr As String, _
        strCCName As String, _
        strCCAddr As String
    If strFilename <> "" Then
        If TypeName(olkFld) <> "Nothing" Then
            intVer = GetOutlookVersion()
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            Set excApp = CreateObject("Excel.Application")
            If objFSO.FileExists(strFilename) Then
                Set excWkb = excApp.Workbooks.Open(strFilename)
                If EXPORT_NEWSHEET Then
                    Set excWks = excWkb.Worksheets.Add()
                    excWks.Name = Format(Date, "m-dd-yy")
                Else
                    Set excWks = excWkb.Worksheets(1)
                End If
            Else
                Set excWkb = excApp.Workbooks.Add()
                Set excWks = excWkb.Worksheets(1)
            End If
            'Write Excel Column Headers
            With excWks
                .Cells(1, 1) = "Subject"
                .Cells(1, 2) = "From Name"
                .Cells(1, 3) = "From Address"
                .Cells(1, 4) = "To Name"
                .Cells(1, 5) = "To Address"
                .Cells(1, 6) = "CC Name"
                .Cells(1, 7) = "CC Address"
            End With
            intRow = 2
            'Write messages to spreadsheet
            For Each olkMsg In olkFld.Items
                If olkMsg.Class = olMail Then
                    strToName = ""
                    strToAddr = ""
                    strCCName = ""
                    strCCAddr = ""
                    For Each olkRcp In olkMsg.Recipients
                        Select Case olkRcp.Type
                            Case olTo
                                strToName = strToName & olkRcp.Name & "; "
                                strToAddr = strToAddr & X400toSMTP(olkRcp.AddressEntry.Address) & "; "
                            Case olCC
                                strCCName = strCCName & olkRcp.Name & "; "
                                strCCAddr = strCCAddr & X400toSMTP(olkRcp.AddressEntry.Address) & "; "
                        End Select
                    Next
                    'Add a row for each field in the message you want to export
                    excWks.Cells(intRow, 1) = olkMsg.Subject
                    excWks.Cells(intRow, 2) = olkMsg.SenderName
                    excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVer)
                    If Len(strToName) > 0 Then
                        excWks.Cells(intRow, 4) = Left(strToName, Len(strToName) - 2)
                    Else
                        excWks.Cells(intRow, 4) = ""
                    End If
                    If Len(strToAddr) > 0 Then
                        excWks.Cells(intRow, 5) = Left(strToAddr, Len(strToAddr) - 2)
                    Else
                        excWks.Cells(intRow, 5) = ""
                    End If
                    If Len(strCCName) > 0 Then
                        excWks.Cells(intRow, 6) = Left(strCCName, Len(strCCName) - 2)
                    Else
                        excWks.Cells(intRow, 6) = ""
                    End If
                    If Len(strCCAddr) > 0 Then
                        excWks.Cells(intRow, 7) = Left(strCCAddr, Len(strCCAddr) - 2)
                    Else
                        excWks.Cells(intRow, 7) = ""
                    End If
                    intRow = intRow + 1
                End If
            Next
            Set olkMsg = Nothing
        Else
            MsgBox "The folder pointed to by the path '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
        End If
    Else
        MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
    End If
    If objFSO.FileExists(strFilename) Then
        excWkb.Save
    Else
        excWkb.SaveAs strFilename
    End If
    excWkb.Close True
    Set olkMsg = Nothing
    Set olkFld = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

Function X400toSMTP(strAdr As String) As String
    Dim olkRcp As Outlook.RECIPIENT, olkUsr As Outlook.ExchangeUser
    Set olkRcp = Session.CreateRecipient(strAdr)
    If olkRcp.AddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
        olkRcp.Resolve
        Set olkUsr = olkRcp.AddressEntry.GetExchangeUser
        X400toSMTP = olkUsr.PrimarySmtpAddress
    Else
        X400toSMTP = strAdr
    End If
    Set olkRcp = Nothing
    Set olkUsr = Nothing
End Function

Select allOpen in new window

BlueDevilFan,

Just to clarify, this script is run from Outlook, and not from the Excel woorkbook.

Tosagua

That's correct.

BlueDevilFan,

In between crises, I have been working on the macro, but I encoutered a 'Run-time error.
I think I missed a step. An object could not be found.
See attached file.

Please advise.

Tosagua
Outlook-Export.docx

I will withdraw interest in this thread, then.

Tosagua,

Are you familiar with using the debugger in Outlook?  If so, please check to see if olkRcp is a recipient object.  If it is, then look at its properties and see if AddressEntry is set to Nothing.

BlueDevilFan,

I cannot find olkRcp. The Debug is rather limited, and I cannot find the properties of the classes. See attached. This is Visual Basic for Applications 7.0, under Outlook 2010.

Tosagua
Outlook-Export--2.docx

You're looking in the list of objects.  That's not the right place.  If it's not already visible, turn on the "Locals Window" (View > Locals Window).  It'll appear at the bottom of the screen.  Look for olkRcp.

BlueDevilFan,

Found it. See attached.

Tosagua
Outlook-Export--3.docx

Interesting.  Please replace the function X400toSMTP with the version below and try again.  Although the code worked fine when I tested it I see that I had one line out of place.  I've corrected that in this version.

Function X400toSMTP(strAdr As String) As String
    Dim olkRcp As Outlook.RECIPIENT, olkUsr As Outlook.ExchangeUser
    Set olkRcp = Session.CreateRecipient(strAdr)
    olkRcp.Resolve
    If olkRcp.AddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
        Set olkUsr = olkRcp.AddressEntry.GetExchangeUser
        X400toSMTP = olkUsr.PrimarySmtpAddress
    Else
        X400toSMTP = strAdr
    End If
    Set olkRcp = Nothing
    Set olkUsr = Nothing
End Function

Select allOpen in new window

BlueDevilFan,

Although you moved the "olkRcp.Resolve", above the offending:
"If olkRcp.AddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Then" line,
It is the same error message, "An object cannot be found".

The only script that I modified was in the Sub Export Controller() :

Sub ExportController()
    'Add as many exports as you need. Each export is controlled by a line like the following
    'The format of the command is ExportMessagesToExcel "Path to Workbook", Outlook folder

    ExportMessagesToExcel "I:\WHSE\BDG\Outlook\Inbox.xlsx", Session.GetDefaultFolder(olFolderInbox)

    MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub

Tosagua

Apparently the code is unable to resolve the address being passed.  I can't imagine how that's possible.  The message came in with that address so there's no reason I can think of why Outlook shouldn't be able to resolve it.

BlueDevilFan,

Since it is an Object that cannot be found, could this have anything to do with early binding, as opposed to late binding ? Did an Object have to be defined at a prior point ?

Tosaqua

Another solution has been used.

Really appreciate everyone's input.

Thank you,

Tosagua