Export from Outlook to Excel - Follow on from Q25831986

In [ThisOutlookSession]

'### Context
Private WithEvents ActiveExplorerCBars As CommandBars
Private WithEvents ContextButton As CommandBarButton 'A flag, so we don't respond to our own changes in OnUpdate Private IgnoreCommandbarsChanges As Boolean
'### Context

Private Sub Application_Startup()
'### Context
    Set ActiveExplorerCBars = ActiveExplorer.CommandBars
'### Context
End Sub


'### Context
Private Sub ContextButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    GetTheData
End Sub

'This fires when the user right-clicks a contact, and also for a lot of other things!
Private Sub ActiveExplorerCBars_OnUpdate()
    Dim bar As CommandBar

    If IgnoreCommandbarsChanges Then Exit Sub

    'Try for the context menu
    On Error Resume Next
    Set bar = ActiveExplorerCBars.Item("Context Menu")
    On Error GoTo 0

    If Not bar Is Nothing Then
        AddContextButton bar
    End If
End Sub

Private Sub AddContextButton(ContextMenu As CommandBar)
    Dim b As CommandBarButton
    Dim Control As CommandBarControl

    'User cannot play with the Context Menu, so we know there is at most
    'only one copy of the control there
    Set Control = ContextMenu.FindControl(Type:=MsoControlType.msoControlButton, Tag:="UpdateExcel")

    If Control Is Nothing Then

        'Unprotect context menu
        ChangingBar ContextMenu, Restore:=False

        'Create the control
        Set Control = ContextMenu.Controls.Add(Type:=msoControlButton)

        'Set up control
        Control.Tag = "UpdateExcel"
        Control.Caption = "Update Excel"
        Control.Priority = 1
        Control.Visible = True

        'Reprotect context menu
        ChangingBar ContextMenu, Restore:=True

        'Hook the Click event
        Set ContextButton = Control

    Else
        'Note that Outlook has a bad habbit of changing our Context Menu buttons
        'to be priority dropped.
        Control.Priority = 1
    End If

End Sub

'Called once to prepare for changes to the command bar, then again with 'Restore = true once changes are complete.
Private Sub ChangingBar(bar As CommandBar, Restore As Boolean)

  Static oldProtectFromCustomize, oldIgnore As Boolean

  If Restore Then

    'Restore the Ignore Changes flag
    IgnoreCommandbarsChanges = oldIgnore

    'Restore the protect-against-customization bit
    If oldProtectFromCustomize Then bar.Protection = _
      bar.Protection And msoBarNoCustomize

  Else

    'Store the old Ignore Changes flag
    oldIgnore = IgnoreCommandbarsChanges
    IgnoreCommandbarsChanges = True

    'Store old protect-against-customization bit setting then clear
    'CAUTION: Be careful not to alter the property if there is no need,
    'as changing the Protection will cause any visible CommandBarPopup
    'to disappear unless it is the popup we are altering.
    oldProtectFromCustomize = bar.Protection And msoBarNoCustomize
    If oldProtectFromCustomize Then bar.Protection = bar.Protection _
      And Not msoBarNoCustomize

  End If

End Sub
'### Context





In [Module1]
Sub GetTheData()
      
    Dim TheMessage As String
    Dim arr(1 To 12, 1 To 2) As Variant
    Dim Counter As Long
    Dim TheLine As String
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlWs As Object
    Dim NextR As Long
    Dim ColNum As Long
    Dim ValueStr As String
    Dim Interests As Variant
    Dim XLWBook As String
    
    XLWBook = "C:\XLData\Responses.xls"  'change as needed
      
    ' On second dimension, 1=headings from message, 2=headings in Excel file
      
    arr(1, 1) = "First Name": arr(1, 2) = "First Name"
    arr(2, 1) = "Surname": arr(2, 2) = "Surname"
    arr(3, 1) = "Email": arr(3, 2) = "Email"
    arr(4, 1) = "Address": arr(4, 2) = "Address1"
    arr(5, 1) = "Address 2": arr(5, 2) = "Address2"
    arr(6, 1) = "Town": arr(6, 2) = "Town"
    arr(7, 1) = "County": arr(7, 2) = "County"
    arr(8, 1) = "Postcode": arr(8, 2) = "Postcode"
    arr(9, 1) = "Telephone": arr(9, 2) = "Telephone"
    arr(10, 1) = "Age range": arr(10, 2) = "Age Range"
    arr(11, 1) = "Interests": arr(11, 2) = "Interests"
      
    TheMessage = Application.ActiveExplorer.Selection(1)
      
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open(XLWBook)
    Set xlWs = xlWb.Worksheets(1)
    
    With xlWs
        NextR = .Cells(.Rows.Count, "a").End(-4162).Row + 1 '-4162 = xlUp
        For Counter = 1 To 11
            TheLine = RegExpFind(TheMessage, arr(Counter, 1) & ":[^\n]*\n", 1, False)
            If TheLine <> "" Then
                ValueStr = Split(TheLine, ":")(1)
                ColNum = xlApp.Match(arr(Counter, 2), .[1:1], 0)
                If Counter < 11 Then
                    .Cells(NextR, ColNum) = Trim(ValueStr)
                Else
                    Interests = Split(Replace(ValueStr, ", ", ","), ",")
                    .Cells(NextR, ColNum).resize(1, UBound(Interests) + 1).Value = Interests
                End If
                .Cells(NextR, "a") = Date
            End If
        Next
    End With
      
    xlWb.Save
    xlWb.Close
    Set xlWs = Nothing
    Set xlWb = Nothing
    xlApp.Quit
    Set xlApp = Nothing
      
    MsgBox "Done"
      
End Sub
  
Function RegExpFind(LookIn As String, PatternStr As String, Optional Pos, _
    Optional MatchCase As Boolean = True, Optional ReturnType As Long = 0, _
    Optional MultiLine As Boolean = False)
      
    ' Function written by Patrick G. Matthews.  You may use and distribute this code freely,
    ' as long as you properly credit and attribute authorship and the URL of where you
    ' found the code
      
    ' For more info, please see:
    ' http://www.experts-exchange.com/articles/Programming/Languages/Visual_Basic/Using-Regular-Expressions-in-Visual-Basic-for-Applications-and-Visual-Basic-6.html
      
    ' This function relies on the VBScript version of Regular Expressions, and thus some of
    ' the functionality available in Perl and/or .Net may not be available.  The full extent
    ' of what functionality will be available on any given computer is based on which version
    ' of the VBScript runtime is installed on that computer
      
    ' This function uses Regular Expressions to parse a string (LookIn), and return matches to a
    ' pattern (PatternStr).  Use Pos to indicate which match you want:
    ' Pos omitted               : function returns a zero-based array of all matches
    ' Pos = 1                   : the first match
    ' Pos = 2                   : the second match
    ' Pos = <positive integer>  : the Nth match
    ' Pos = 0                   : the last match
    ' Pos = -1                  : the last match
    ' Pos = -2                  : the 2nd to last match
    ' Pos = <negative integer>  : the Nth to last match
    ' If Pos is non-numeric, or if the absolute value of Pos is greater than the number of
    ' matches, the function returns an empty string.  If no match is found, the function returns
    ' an empty string.  (Earlier versions of this code used zero for the last match; this is
    ' retained for backward compatibility)
      
    ' If MatchCase is omitted or True (default for RegExp) then the Pattern must match case (and
    ' thus you may have to use [a-zA-Z] instead of just [a-z] or [A-Z]).
      
    ' ReturnType indicates what information you want to return:
    ' ReturnType = 0            : the matched values
    ' ReturnType = 1            : the starting character positions for the matched values
    ' ReturnType = 2            : the lengths of the matched values
      
    ' If you use this function in Excel, you can use range references for any of the arguments.
    ' If you use this in Excel and return the full array, make sure to set up the formula as an
    ' array formula.  If you need the array formula to go down a column, use TRANSPOSE()
      
    ' Note: RegExp counts the character positions for the Match.FirstIndex property as starting
    ' at zero.  Since VB6 and VBA has strings starting at position 1, I have added one to make
    ' the character positions conform to VBA/VB6 expectations
      
    ' Normally as an object variable I would set the RegX variable to Nothing; however, in cases
    ' where a large number of calls to this function are made, making RegX a static variable that
    ' preserves its state in between calls significantly improves performance
      
    Static RegX As Object
    Dim TheMatches As Object
    Dim Answer()
    Dim Counter As Long
      
    ' Evaluate Pos.  If it is there, it must be numeric and converted to Long
      
    If Not IsMissing(Pos) Then
        If Not IsNumeric(Pos) Then
            RegExpFind = ""
            Exit Function
        Else
            Pos = CLng(Pos)
        End If
    End If
      
    ' Evaluate ReturnType
      
    If ReturnType < 0 Or ReturnType > 2 Then
        RegExpFind = ""
        Exit Function
    End If
      
    ' Create instance of RegExp object if needed, and set properties
      
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    With RegX
        .Pattern = PatternStr
        .Global = True
        .IgnoreCase = Not MatchCase
        .MultiLine = MultiLine
    End With
          
    ' Test to see if there are any matches
      
    If RegX.Test(LookIn) Then
          
        ' Run RegExp to get the matches, which are returned as a zero-based collection
          
        Set TheMatches = RegX.Execute(LookIn)
          
        ' Test to see if Pos is negative, which indicates the user wants the Nth to last
        ' match.  If it is, then based on the number of matches convert Pos to a positive
        ' number, or zero for the last match
          
        If Not IsMissing(Pos) Then
            If Pos < 0 Then
                If Pos = -1 Then
                    Pos = 0
                Else
                      
                    ' If Abs(Pos) > number of matches, then the Nth to last match does not
                    ' exist.  Return a zero-length string
                      
                    If Abs(Pos) <= TheMatches.Count Then
                        Pos = TheMatches.Count + Pos + 1
                    Else
                        RegExpFind = ""
                        GoTo Cleanup
                    End If
                End If
            End If
        End If
          
        ' If Pos is missing, user wants array of all matches.  Build it and assign it as the
        ' function's return value
          
        If IsMissing(Pos) Then
            ReDim Answer(0 To TheMatches.Count - 1)
            For Counter = 0 To UBound(Answer)
                Select Case ReturnType
                    Case 0: Answer(Counter) = TheMatches(Counter)
                    Case 1: Answer(Counter) = TheMatches(Counter).FirstIndex + 1
                    Case 2: Answer(Counter) = TheMatches(Counter).Length
                End Select
            Next
            RegExpFind = Answer
          
        ' User wanted the Nth match (or last match, if Pos = 0).  Get the Nth value, if possible
          
        Else
            Select Case Pos
                Case 0                          ' Last match
                    Select Case ReturnType
                        Case 0: RegExpFind = TheMatches(TheMatches.Count - 1)
                        Case 1: RegExpFind = TheMatches(TheMatches.Count - 1).FirstIndex + 1
                        Case 2: RegExpFind = TheMatches(TheMatches.Count - 1).Length
                    End Select
                Case 1 To TheMatches.Count      ' Nth match
                    Select Case ReturnType
                        Case 0: RegExpFind = TheMatches(Pos - 1)
                        Case 1: RegExpFind = TheMatches(Pos - 1).FirstIndex + 1
                        Case 2: RegExpFind = TheMatches(Pos - 1).Length
                    End Select
                Case Else                       ' Invalid item number
                    RegExpFind = ""
            End Select
        End If
      
    ' If there are no matches, return empty string
      
    Else
        RegExpFind = ""
    End If
      
Cleanup:
    ' Release object variables
      
    Set TheMatches = Nothing
      
End Function

Select allOpen in new window