将电子邮件从 Outlook 导出到 Excel 包括图像

Question

我目前正在处理我的项目，即将电子邮件从 Outlook 导出到我的 Excel 文件。

我当前的代码只导出文本而不是图像。我的一些电子邮件有截图（.png/.jpg）。

有解决办法吗？

这是我当前在 Excel 上的代码：

Sub getDataFromOutlook()

'~~Declarations~~'
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer

'~~Set email to be saved~~'
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("SAMPLE")

i = 1


For Each OutlookMail In Folder.Items
'~~Write to Excel~~'
If OutlookMail.ReceivedTime >= Range("email_Receipt_Date").Value Then
    Range("email_Subject").Offset(i, 0).Value = OutlookMail.Subject
    Range("email_Subject").Offset(i, 0).Columns.AutoFit
    Range("email_Subject").Offset(i, 0).VerticalAlignment = xlTop
    Range("email_Date").Offset(i, 0).Value = OutlookMail.ReceivedTime
    Range("email_Date").Offset(i, 0).Columns.AutoFit
    Range("email_Date").Offset(i, 0).VerticalAlignment = xlTop
    Range("email_Sender").Offset(i, 0).Value = OutlookMail.SenderName
    Range("email_Sender").Offset(i, 0).Columns.AutoFit
    Range("email_Sender").Offset(i, 0).VerticalAlignment = xlTop
    Range("email_Body").Offset(i, 0).Value = OutlookMail.Body
    Range("email_Body").Offset(i, 0).Columns.AutoFit
    Range("email_Body").Offset(i, 0).VerticalAlignment = xlTop

    i = i + 1
End If

Next OutlookMail

'~~Set to Null~~'
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub

Answer 1

看看这篇文章：

How to copy Outlook mail message into excel using VBA or Macros

我认为它应该可以满足您的需求（向下滚动到底部）。

Answer 2

你试过Attachments吗？我没有必要这样做，但这是我最初努力的地方。

MailItem.Attachments.Item(0) 让您处理第一个附件。

由于您的变量 OutlookMail 包含 MailItem，所以我要尝试的第一件事是...

ActiveSheet.Pictures.Insert(OutlookMail.Attachments.Item(0))

我会尝试的第二件事是寻找答案。

从电子邮件中提取图片并将图片插入 Excel 并不是什么晦涩难懂的任务，因此有很多详细的示例可供查找它们的人使用。

当我问我的滑板是否在前院时，我想起了祖母的回答。 “用眼睛看，而不是用嘴看”，这是她告诉我的。在这里感觉很合适。