Save Outlook attachment into an Excel cell, as OLEObject in VBA

[JChojnacki]

I am trying to find out if it is possible, from within Excel, to grab attachments and save them as an OLEObject in a specific cell. The idea being I am searching a Outlook folder for emails with a specific subject and then capturing some data about each email.

The user wants to be able to know if any of the responses have an attachment. Which is easy enough. But I want to go a step further and capture that attachment in Excel for them to be able to read, without having to go back to the email in Outlook.

The code below gets all the data I need. I am just not sure how to get that attachment into a cell.

Oh and as I was typing this, had a thought, what if there are multiple attachments?

Any advice would be appreciated!

Also, I am using Office 2010

Thank you.


For Each Item In ofldr.Items
'Determine if the file is a MailItem or ReportItem and Put on Seperate Tabs
If TypeName(Item) = "MailItem" And Item.Subject Like "*" & theSubj & "*" Then
Worksheets(1).Activate


With ActiveSheet
.Cells(lMrow, 1) = Item.SenderName
.Cells(lMrow, 2) = Item.VotingResponse
If .Cells(lMrow, 2).Value = "" Then
.Cells(lMrow, 2) = ""
End If
.Cells(lMrow, 3) = Item.ReceivedTime
.Cells(lMrow, 4) = Item.Subject
.Cells(lMrow, 5) = Item.Body


If Item.Attachments.Count > 0 Then
'Current State
.Cells(lMrow, 6) = "Yes"
.Cells(lMrow, 6).Font.Color = vbRed

'Future/Desired State
Copy that attachment and put in .Cells(lMrow, 6) as an OLEObject


End If
End With
End If

[D_Marcel]

Welcome to the forum, JChojnacki !
Man, I had the very same demand in the last year but I do not have the code here right now, it's saved at my personal laptop, at home. I'll send to you as soon as I get there. I've found this code researching because I had never developed nothing to Outlook, but declaring the Excel library, I could fit it to my needs. This code will run from Outlook, read all the e-mails in a folder, open an excel workbook and then write into the cells, the e-mail data. It won't store the attachments as an OLE Object, only the name of the files attached, which would help you a lot I believe.


Regards,

Douglas

[D_Marcel]

As I promised, here is the code:

Option ExplicitSub Export_Emails_To_Excel()


Dim I As Long
Dim N As Long
Dim LV_NameSpace As NameSpace
Dim LV_OutlookApp As Outlook.Application
Dim LV_OutItem As Outlook.MailItem
Dim LV_OutItemAtt As Outlook.Attachment
Dim LV_ChosenFolder As Object


Dim LV_ExcelApp As Excel.Application
Dim LV_ExcelWrb As Excel.Workbook
Dim LV_ExcelWks As Excel.Worksheet
Dim LV_ExcelRng As Excel.Range
Dim LV_WksName As String
Dim LV_UsedRows As Long


Set LV_OutlookApp = Outlook.Application
Set LV_NameSpace = LV_OutlookApp.GetNamespace("MAPI")

Set LV_ChosenFolder = LV_NameSpace.PickFolder
If LV_ChosenFolder Is Nothing Then
MsgBox "Ação cancelada pelo usuário", vbOKOnly, "Votorantim Cimentos"
Exit Sub
ElseIf LV_ChosenFolder.Items.Count = 0 Then
MsgBox "Não há e-mails a exportar na pasta selecionada", vbOKOnly, "Votorantim Cimentos"
Exit Sub
ElseIf LV_ChosenFolder.DefaultItemType <> olMailItem Then
MsgBox "Não há e-mails a exportar na pasta selecionada", vbOKOnly, "Votorantim Cimentos"
Exit Sub
End If

LV_WksName = Get_File_Name
If LV_WksName = "Cancel" Then Exit Sub

Set LV_ExcelApp = CreateObject("Excel.Application")
LV_ExcelApp.Application.ScreenUpdating = True
LV_ExcelApp.Workbooks.Open LV_WksName
Set LV_ExcelWrb = LV_ExcelApp.ActiveWorkbook
Set LV_ExcelWks = LV_ExcelWrb.Sheets(1)

LV_ExcelWks.Activate
LV_ExcelApp.Application.Visible = True

LV_ExcelWks.Cells(1, 1).Value = "ENTRY_ID"
LV_ExcelWks.Cells(1, 2).Value = "TO"
LV_ExcelWks.Cells(1, 3).Value = "CC"
LV_ExcelWks.Cells(1, 4).Value = "SUBJECT"
LV_ExcelWks.Cells(1, 5).Value = "SENT_ON"
LV_ExcelWks.Cells(1, 6).Value = "MESSAGE_SIZE"
LV_ExcelWks.Cells(1, 7).Value = "ATTACHMENT_NAME"

For Each LV_OutItem In LV_ChosenFolder.Items
N = N + 1
LV_ExcelApp.Application.StatusBar = "Processing e-mail " & N & " of " & LV_ChosenFolder.Items.Count
If LV_OutItem.Attachments.Count = 0 Then
LV_UsedRows = LV_ExcelWks.UsedRange.Rows.Count
LV_ExcelWks.Cells(LV_UsedRows + 1, 1).Value = LV_OutItem.EntryID
LV_ExcelWks.Cells(LV_UsedRows + 1, 2).Value = LV_OutItem.To
LV_ExcelWks.Cells(LV_UsedRows + 1, 3).Value = LV_OutItem.CC
LV_ExcelWks.Cells(LV_UsedRows + 1, 4).Value = LV_OutItem.Subject
LV_ExcelWks.Cells(LV_UsedRows + 1, 5).Value = LV_OutItem.SentOn
LV_ExcelWks.Cells(LV_UsedRows + 1, 6).Value = LV_OutItem.Size
LV_ExcelWks.Cells(LV_UsedRows + 1, 7).Value = "No Attachments"
Else
For I = 1 To LV_OutItem.Attachments.Count
LV_UsedRows = LV_ExcelWks.UsedRange.Rows.Count
LV_ExcelWks.Cells(LV_UsedRows + 1, 1).Value = LV_OutItem.EntryID
LV_ExcelWks.Cells(LV_UsedRows + 1, 2).Value = LV_OutItem.To
LV_ExcelWks.Cells(LV_UsedRows + 1, 3).Value = LV_OutItem.CC
LV_ExcelWks.Cells(LV_UsedRows + 1, 4).Value = LV_OutItem.Subject
LV_ExcelWks.Cells(LV_UsedRows + 1, 5).Value = LV_OutItem.SentOn
LV_ExcelWks.Cells(LV_UsedRows + 1, 6).Value = (((LV_OutItem.Size) / 1024) / 1024)
LV_ExcelWks.Cells(LV_UsedRows + 1, 7).Value = LV_OutItem.Attachments(I)
Next I
End If
Next LV_OutItem
LV_ExcelWks.Columns("A:G").EntireColumn.AutoFit
LV_ExcelWks.Range(Cells(1, 1), Cells(1, 7)).Select
LV_ExcelWks.Range(Selection, Selection.End(xlDown)).Select
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
LV_ExcelWks.Range(Cells(1, 1), Cells(1, 7)).Select
With Selection.Font
.Bold = True
End With
LV_ExcelWks.Cells(1, 1).Select
LV_ExcelApp.Application.StatusBar = False
LV_ExcelWrb.Save
LV_ExcelWrb.Close
LV_ExcelApp.Application.Quit

Set LV_NameSpace = Nothing
Set LV_OutlookApp = Nothing
Set LV_OutItem = Nothing
Set LV_OutItemAtt = Nothing
Set LV_ChosenFolder = Nothing

Set LV_ExcelApp = Nothing
Set LV_ExcelWrb = Nothing
Set LV_ExcelWks = Nothing
Set LV_ExcelRng = Nothing

End Sub
Public Function Get_File_Name() As Variant


Dim FV_Index As Integer
Dim FV_FileArray As Variant
Dim FV_ExcelApp As Excel.Application
Dim FV_FileDialog As Office.FileDialog


Set FV_ExcelApp = New Excel.Application
FV_ExcelApp.Visible = False
Set FV_FileDialog = FV_ExcelApp.Application.FileDialog(msoFileDialogOpen)
With FV_FileDialog
.Filters.Clear
.Filters.Add "Pastas de Trabalho do Excel", "*.xlsx*", 1
.Filters.Add "Pastas de Trabalho do Excel 97-2003", "*.xls*", 1
.Title = "Selecione a planilha de destino"
.AllowMultiSelect = False
If .Show = -1 Then
ReDim FV_FileArray(.SelectedItems.Count)
For FV_Index = 1 To .SelectedItems.Count
FV_FileArray(FV_Index) = .SelectedItems(FV_Index)
Next FV_Index
Else
ReDim FV_FileArray(1)
FV_FileArray(1) = "Cancel"
End If
End With
Get_File_Name = FV_FileArray(1)
FV_ExcelApp.Application.Quit
Set FV_ExcelApp = Nothing


End Function

Here goes the instructions:

1. Open your MS Outlook, press ALT + F11. Go to Insert > New Module, and then paste the code inside;
2. Go to Tools > References and activate the Microsoft Excel Object Library;
3. Create a new "blank" excel workbook and save somewhere in your machine;

The macro will call the FileDialog and ask to select a workbook to put the data into.

Hope it helps! Let me know if it works for you.

Regards,

Douglas

[JChojnacki]

Thanks. Doesn't quite do what I need. However, I did see some pieces of code I might find useful. :)

[JChojnacki]

Well, I was able to come up with a solution that will work. It is not exactly what I want. Instead of adding any of the email attachments as an OLEObject on my report worksheet, on each instance I am going to create a new worksheet, name it after the sender and display their attachment.

For Each Item In ofldr.Items
'Determine if the file is a MailItem or ReportItem and Put on Seperate Tabs
If TypeName(Item) = "MailItem" And Item.Subject Like "*" & theSubj & "*" Then
Worksheets("Ack").Activate

With ActiveSheet
.Cells(lMrow, 1) = Item.SenderName
.Cells(lMrow, 2) = Item.VotingResponse
If .Cells(lMrow, 2).Value = "" Then
.Cells(lMrow, 2) = ""
End If
.Cells(lMrow, 3) = Item.ReceivedTime
.Cells(lMrow, 4) = Item.Subject
.Cells(lMrow, 5) = Item.Body

If Item.Attachments.Count > 0 Then
Dim outAttachment As Outlook.Attachment
saveFolder = "C:\Temp\"
If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"
m = 1
For Each outAttachment In Item.Attachments
If outAttachment.Filename Like "*.png" Then
Else
Dim fName As String
Dim sender As String
Dim x As OLEObject
Dim z As Long

sender = Item.sender
fName = outAttachment.Filename
outAttachment.SaveAsFile saveFolder & fName
sFileName = saveFolder & fName
sender = sender & " " & m

Sheets.Add.Name = sender
Set x = ActiveSheet.OLEObjects.Add(Filename:=sFileName, Link:=False, DisplayAsIcon:=False)
Sheets(sender).Move After:=Sheets("Email Report")
Sheets(sender).Tab.ColorIndex = 3
With New FileSystemObject
If .FileExists(sFileName) Then
.DeleteFile sFileName
End If
End With
m = m + 1

End If

Next
.Cells(lMrow, 6) = "Yes"
.Cells(lMrow, 6).Font.Color = vbRed
End If

End With
lMrow = lMrow + 1

End If
Next Item