How to save email's metadata in xslx

Dear All,
As I am VBA beginner I would like to ask you for help in one of my business case
I need to (only for specific, selected by me email):
1. Save email attachments in a proproper loctation
2. Save in a common excel file basic information about the emial. DATE RECEIVED - FROM (sender) - NUMBER OF FILES (attached to the email) - CURRENT DATE TIME

Point number 1 I already solved
Point number 2 is still open. :banghead: Can somebody help me with that. Did you have similar task in the past?

Below you can find the code for attachments saving

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim I As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim fs As FileSystemObject


' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next


' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")


' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection


' Set the Attachment folder.
strFolderpath = "C:\LK\SaveAtt"


' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection


' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""


If lngCount > 0 Then


' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
Set fs = New FileSystemObject


For I = lngCount To 1 Step -1


' Save attachment before deleting from item.
' Get the file name.
'strFile = Left(objAttachments.Item(i).FileName, Len(objAttachments.Item(i).FileName) - 4) + "_" + Right("00" + Trim(Str$(Day(Now))), 2) + "_" + Right("00" + Trim(Str$(Month(Now))), 2) + "_" + Right("0000" + Trim(Str$(Year(Now))), 4) + "_" + Right("00" + Trim(Str$(Hour(Now))), 2) + "_" + Right("00" + Trim(Str$(Minute(Now))), 2) + "_" + Right("00" + Trim(Str$(Second(Now))), 2) + Right((objAttachments.Item(i).FileName), 4)
strFile = Right(Left(TimeInMS(), 10), 4) + Right(Left(TimeInMS(), 5), 2) + Left(TimeInMS(), 2) + Replace(Mid(TimeInMS(), 12, 8), ":", "") + Right(TimeInMS(), 2) + Left(objAttachments.Item(I).FileName, Len(objAttachments.Item(I).FileName))
'Left(objAttachments.Item(I).FileName, Len(objAttachments.Item(I).FileName)) + "_" +
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile


' Save the attachment as a file.
objAttachments.Item(I).SaveAsFile strFile


' Delete the attachment.
'objAttachments.Item(I).Delete


'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If


'Use the MsgBox command to troubleshoot. Remove it from the final code.
'MsgBox strDeletedFiles


Next I


' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If


objMsg.Save
End If
Next


ExitSub:


Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub


Public Function TimeInMS() As String
TimeInMS = Strings.Format(Now) & "." & Strings.Right(Strings.Format(Timer, "#0.00"), 2)
End Function

Did you solve this or did you still need help?

Hi Kenneth
I am progressing however quite slow
So far I was able to manage:

Sender;

Subject;

Sender address;

Recieved Time

I still need help on count of attachments
Please find the code I am using

Code:

---

Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String


Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColA, strColB, strColC, strColD, strColE As String
             
' Get Excel set up
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error GoTo 0
   
'## Open a specific workbook to input the data
'the path of the workbook under the windows user account
'enviro = CStr(Environ("USERPROFILE"))
strPath = "C:\LK\ABCDE.xlsx"
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'## End Specific workbook


'## Use New Workbook
'Set xlWB = xlApp.Workbooks.Add
'Set xlSheet = xlWB.Sheets("Sheet1")
'## end use new workbook


' Add column names
  xlSheet.Range("A1") = "Sender"
  xlSheet.Range("B1") = "Sender address"
  'xlSheet.Range("C1") = "Message Body"
  'xlSheet.Range("D1") = "Sent To"
  xlSheet.Range("C1") = "Recieved Time"


' Process the message record
   
  On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1


' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
  For Each obj In Selection


    Set olItem = obj
   
 'collect the fields
    strColA = olItem.SenderName
    strColB = olItem.SenderEmailAddress
    'strColC = olItem.Body
    'strColD = olItem.To
    strColC = olItem.ReceivedTime
   
'### Get all recipient addresses
' instead of To names
Dim strRecipients As String
Dim Recipient As Outlook.Recipient
For Each Recipient In olItem.Recipients
strRecipients = Recipient.Address & "; " & strRecipients
Next Recipient


  strColD = strRecipients
'### end all recipients addresses


'### Get the Exchange address
' if not using Exchange, this block can be removed
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.Session.CreateRecipient(strColB)


If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
    Select Case recip.AddressEntry.AddressEntryUserType
      Case OlAddressEntryUserType.olExchangeUserAddressEntry
        Set olEU = recip.AddressEntry.GetExchangeUser
        If Not (olEU Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
        End If
      Case OlAddressEntryUserType.olOutlookContactAddressEntry
        Set olEU = recip.AddressEntry.GetExchangeUser
        If Not (olEU Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
        End If
      Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
        Set oEDL = recip.AddressEntry.GetExchangeDistributionList
        If Not (oEDL Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
        End If
    End Select
End If
' ### End Exchange section


'write them in the excel sheet
  xlSheet.Range("A" & rCount) = strColA ' sender name
  xlSheet.Range("B" & rCount) = strColB ' sender address
  'xlSheet.Range("C" & rCount) = strColC ' message body
  'xlSheet.Range("D" & rCount) = strColD ' sent to
  xlSheet.Range("C" & rCount) = strColC ' recieved time


'Next row
  rCount = rCount + 1


' size the cells
    xlSheet.Columns("A:C").EntireColumn.AutoFit
    'xlSheet.Columns("C:C").ColumnWidth = 100
    'xlSheet.Columns("D:D").ColumnWidth = 30
    xlSheet.Range("A2").Select
    xlSheet.Columns("A:C").VerticalAlignment = xlTop


Next
xlApp.Visible = True


' to save but not close
'xlWB.Save


' to save and close
'    xlWB.Close 1
'    If bXStarted Then
'        xlApp.Quit
'    End If
' end save and close
   
    Set olItem = Nothing
    Set obj = Nothing
    Set currentExplorer = Nothing
    Set xlSheet = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
End Sub

---

I added CODE tags around your macro to set it off and do some formatting

You can insert the CODE tags using the [#] icon on the command bar

I have been ill so I haven't been able to review this much.

I guess post #3 was supposed to be VBA for Outlook code.

This code is for Excel. If it were me, I would make it even more simple and run the macro from the Excel file that gets the details. You should be able to gleam how I added the Column E attachments count data.

Code:

---

Sub CopyToExcel() 
  Dim xlApp As Application
  Dim xlWB As Workbook
  Dim xlSheet As Worksheet
  Dim bXStarted As Boolean
  Dim enviro As String
  Dim strPath As String
  Dim currentExplorer As Explorer
  Dim Sel As Object
  Dim olItem As Outlook.MailItem
  Dim obj As Object
  Dim strColA$, strColB$, strColC$, strColD$, strColE$
  Dim strRecipients As String
  Dim Recipient As Outlook.Recipient
  Dim olEU As Outlook.ExchangeUser
  Dim oEDL As Outlook.ExchangeDistributionList
  Dim recip As Outlook.Recipient
  Dim rCount As Long
 
  ' Get Excel set up
  On Error Resume Next
  Set xlApp = GetObject(, "Excel.Application")
  If Err <> 0 Then
    Application.StatusBar = "Please wait while Excel source is opened ... "
    Set xlApp = CreateObject("Excel.Application")
    bXStarted = True
  End If
  On Error GoTo 0
   
  '## Open a specific workbook to input the data
  'the path of the workbook under the windows user account
  'enviro = CStr(Environ("USERPROFILE"))
  strPath = "C:\LK\ABCDE.xlsx"
  'strPath = ThisWorkbook.Path & "\OutlookData.xlsx"
  Set xlWB = xlApp.Workbooks.Open(strPath)
  Set xlSheet = xlWB.Sheets("Sheet1")
  '## End Specific workbook
 
  '## Use New Workbook
  'Set xlWB = xlApp.Workbooks.Add
  'Set xlSheet = xlWB.Sheets("Sheet1")
  '## end use new workbook
 
  ' Add column names
  xlSheet.Range("A1") = "Sender"
  xlSheet.Range("B1") = "Sender address"
  xlSheet.Range("C1") = "Recieved Time"
  xlSheet.Range("D1") = "Recipient(s)"
  xlSheet.Range("E1") = "Attachments Count"
 
  ' Process the message record
  'On Error Resume Next
  'Find the next empty line of the worksheet
  'rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
  rCount = xlSheet.Cells(xlSheet.Rows.Count, "A").End(xlUp).Row
  'needed for Exchange 2016. Remove if causing blank lines.
  rCount = rCount + 1
 
  ' get the values from outlook
  Set currentExplorer = Outlook.ActiveExplorer
  Set Sel = currentExplorer.Selection
  For Each obj In Sel
    If TypeName(obj) <> "MailItem" Then GoTo NextObj
    Set olItem = obj 'can be elimated and just use obj rather than olItem
    'collect the fields
    strColA = olItem.SenderName
    strColB = olItem.SenderEmailAddress
    'strColC = olItem.Body
    'strColD = olItem.To
    strColC = olItem.ReceivedTime
    strColE = olItem.Attachments.Count
   
    '### Get all recipient addresses
    ' instead of To names
    For Each Recipient In olItem.Recipients
      strRecipients = Recipient.Address & "; " & strRecipients
    Next Recipient
 
    strColD = strRecipients
    '### end all recipients addresses
     
    '### Get the Exchange address
    ' if not using Exchange, this block can be removed
    Set recip = Outlook.Session.CreateRecipient(strColB)
   
    If InStr(1, strColB, "/") > 0 Then
      ' if exchange, get smtp address
      Select Case recip.AddressEntry.AddressEntryUserType
        Case OlAddressEntryUserType.olExchangeUserAddressEntry
          Set olEU = recip.AddressEntry.GetExchangeUser
          If Not (olEU Is Nothing) Then strColB = olEU.PrimarySmtpAddress
        Case OlAddressEntryUserType.olOutlookContactAddressEntry
          Set olEU = recip.AddressEntry.GetExchangeUser
          If Not (olEU Is Nothing) Then strColB = olEU.PrimarySmtpAddress
        Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
          Set oEDL = recip.AddressEntry.GetExchangeDistributionList
          If Not (oEDL Is Nothing) Then strColB = olEU.PrimarySmtpAddress
      End Select
    End If
   
    ' ### End Exchange section
    'write them in the excel sheet
    xlSheet.Range("A" & rCount) = strColA ' sender name
    xlSheet.Range("B" & rCount) = strColB ' sender address
    'xlSheet.Range("C" & rCount) = strColC ' message body
    xlSheet.Range("C" & rCount) = strColC ' recieved time
    xlSheet.Range("D" & rCount) = strColD ' sent to
    xlSheet.Range("E" & rCount) = strColE ' sent to/recipient(s)
    'Next row
    rCount = rCount + 1
NextObj:
  Next obj
 
  'Format columns
  xlSheet.Columns("A:E").EntireColumn.AutoFit
  'xlSheet.Columns("C:C").ColumnWidth = 100
  'xlSheet.Columns("D:D").ColumnWidth = 30
  'xlSheet.Range("A2").Select
  xlSheet.Columns("A:E").VerticalAlignment = xlTop
 
  xlApp.Visible = True
  ' to save but not close
  'xlWB.Save
 
 
  ' to save and close
  '    xlWB.Close 1
  '    If bXStarted Then
  '        xlApp.Quit
  '    End If
  ' end save and close
 
  Set olItem = Nothing
  Set obj = Nothing
  Set currentExplorer = Nothing
  Set xlSheet = Nothing
  Set xlWB = Nothing
  Set xlApp = Nothing
 
  MsgBox ""
End Sub

---

Thank you very much for help and sorry for a late response. I was not available for couple of days.
Now I have two solutions. Cos I anhanced my outllok macro with your "attachments count" code I can either use outlook or excel
My last concern in this thread is how to restrict olItem.Attachments.Count to only specific files (e.g. csv. or xslx.)
I tried with "IF" under "strColF =" but I have still to less experience to manage it
BR
LukasK

Change the Case lines to suit.

Code:

---

Dim ii As Integer, jj As Integer, fso As Object
  Set fso = CreateObject("Scripting.FileSystemObject")

strColE = olItem.Attachments.Count
    If strColE > 0 Then
      jj = 0
      For ii = 1 To olItem.Attachments.Count
        Select Case fso.GetExtensionName(olItem.Attachments(ii))
          Case "xlsx"
            jj = jj + 1
          Case "xlsm"
            jj = jj + 1
          Case "pdf"
            jj = jj + 1
          Case Else
        End Select
      Next ii
      strColE = jj
    End If

---

Hi Kenneth
Thank you once again
I wrote a funcion for this


Public Function B_AttCOunt() As String
Dim oItem As Object
Dim oAttachment As attachment
Dim iAtt As Integer
For Each oItem In ActiveExplorer.Selection
For Each oAttachment In oItem.Attachments
If LCase(Right(oAttachment.FileName, 4)) = ".csv" Then
iAtt = iAtt + 1
End If
Next oAttachment
Next oItem
B_AttCOunt = iAtt
'MsgBox "Selected " & ActiveExplorer.Selection.Count & " message(s) with " & _
'iAtt & " .csv attachement(s)"

End Function

and ahave assigned it to
strColF = B_AttCOunt()