Question

我有以下代码可以从特定发件人处获取电子邮件信息。我无法将信息复制到 Excel。

我可以在即时窗口中看到信息，但看不到其他信息。

Sub Getemaildetails()

Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim Filtertext As String

Set ol = New Outlook.Application
Set ns = ol.GetNamespace("Mapi")
Set fol = ns.GetDefaultFolder(olFolderInbox)

Filtertext = "[SenderName]= 'Eskalem Bogale'"

Set i = fol.Items.Find(Filtertext)

Range("A2", Range("A2").End(xlDown).End(xlToRight)).Clear

If i Is Nothing Then
    MsgBox "Nothing was found.", vbExclamation
    Exit Sub
End If

If i.Class <> olMail Then
    MsgBox "Item is not an email.", vbExclamation
    Exit Sub
End If

Set mi = i

Debug.Print mi.Subject

End Sub

Answer 1

由于您没有尝试澄清我的澄清问题，因此我仅假设我正确理解了您的需求。意思是从该特定发件人收到的所有电子邮件中返回日期。应该是很快的，把数据放到一个数组中，然后一次性丢弃处理结果：

Sub GetEmaildetails()
Dim ol As Outlook.Application, ns As Outlook.NameSpace
Dim fol As Outlook.folder, i As Outlook.items, arrM
Dim mi As Outlook.MailItem, Filtertext As String, iEm As Long

Set ol = New Outlook.Application
Set ns = ol.GetNamespace("Mapi")
Set fol = ns.GetDefaultFolder(olFolderInbox)

Filtertext = "[SenderName]= 'Eskalem Bogale'"
'You can also use:
'Filtertext = "[From] = 'Eskalem Bogale'"

Set i = fol.items.Restrict(Filtertext)

Range("A2", Range("A2").End(xlDown).End(xlToRight)).Clear

If i Is Nothing Then
MsgBox "Nothing was found.", vbExclamation
    Exit Sub
End If

ReDim arrM(1 To i.count + 1, 1 To 3)
iEm = 2
For Each mi In i
   arrM(iEm, 1) = mi.Subject
   arrM(iEm, 2) = mi.ReceivedTime
   arrM(iEm, 3) = mi.size
   iEm = iEm + 1
   'it can also return Body, Catetories...
Next
Range("A2").Resize(UBound(arrM), 3).Value = arrM
MsgBox "Ready..."
End Sub

如何将电子邮件信息复制到 Excel？

1 个答案: