Van en Datum uit e-mailheader kopieren naar klembord

Sub GetValuesFromInternetHeader()
    Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
    Dim strHeader As String
    Dim strResult As String
    Dim strResults As String
    Dim Reg1 As Object
    Dim M1 As Object
    Dim M As Object
 
    For Each olItem In Application.ActiveExplorer.Selection
        strHeader = GetInetHeaders(olItem)
    
      Set Reg1 = CreateObject("VBScript.RegExp")
    With Reg1
        .Pattern = "(From:\s(.*))"
        .Global = True
    End With
    
    If Reg1.test(strHeader) Then
    
        Set M1 = Reg1.Execute(strHeader)
        For Each M In M1
' 0 = everything in the first set of ()
' 1 = everything in the second set of ()
        Debug.Print M.SubMatches(0)
        strResult = M.SubMatches(1)

' do something with the result
        strResults = strResult & vbCrLf & vbCrLf & strResults
        Next
    End If
    
    Next

        Set olMsg = Application.CreateItem(olMailItem)
        With olMsg
            .BodyFormat = olFormatPlain
            .Body = strResults
            .Display
        End With
    Set olMsg = Nothing
End Sub

Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
    ' Purpose: Returns the internet headers of a message.'
    ' Written: 4/28/2009'
    ' Author:  BlueDevilFan'
    ' //techniclee.wordpress.com/
    ' Outlook: 2007'
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
    Dim olkPA As Outlook.PropertyAccessor
    Set olkPA = olkMsg.PropertyAccessor
    GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
    Set olkPA = Nothing
End Function

For i = 1 To 2

With Reg1
    Select Case i
    Case 1
        .Pattern = "(From:\s(.*))"
        .Global = True
        
    Case 2
       .Pattern = "(Date:\s(.*))"
       .Global = True
    End Select
End With

Public Sub SenderAndDate()
    Dim DataObj As New MSForms.DataObject
    Dim CurrentExplorer As Explorer
    Dim obj As Object
    
    Set CurrentExplorer = Application.ActiveExplorer
    Set Selection = CurrentExplorer.Selection
    
    For Each obj In Selection
       With obj
          DataObj.SetText .SenderName & " <" & .SenderEmailAddress & ">" & " " & .ReceivedTime
          DataObj.PutInClipboard
       End With
    Next

    Set CurrentExplorer = Nothing
    Set Selection = Nothing
    Set DataObj = Nothing
End Sub