Consulting

Results 1 to 8 of 8

Thread: How to save email's metadata in xslx

  1. #1
    VBAX Newbie
    Joined
    Jun 2019
    Posts
    4
    Location

    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. 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

  2. #2
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,783
    Location
    Did you solve this or did you still need help?

  3. #3
    VBAX Newbie
    Joined
    Jun 2019
    Posts
    4
    Location
    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
    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
    Last edited by Paul_Hossler; 06-27-2019 at 06:30 AM. Reason: Added CODE tags

  4. #4
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,598
    Location
    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
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  5. #5
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,783
    Location
    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.
    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

  6. #6
    VBAX Newbie
    Joined
    Jun 2019
    Posts
    4
    Location
    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

  7. #7
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,783
    Location
    Change the Case lines to suit.

    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

  8. #8
    VBAX Newbie
    Joined
    Jun 2019
    Posts
    4
    Location
    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()

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •