Question

以下代码来自另一个SO帖子：Excel VBA Code to retrieve e-mails from outlook。

目的是从Outlook电子邮件中查找信息并将其放入Excel中。

Sub test2()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder
Dim i As Long
Dim x As Date
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long

Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Sheet1")
wb.Activate
ws.Select

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = Date


For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name)
For i = olFolder.Items.Count To 1 Step -1

 If TypeOf olFolder.Items(i) Is MailItem Then
        Set olMail = olFolder.Items(i)
            For iCounter = 2 To lrow
            If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then
                With ws
                   lrow = .Range("A" & .Rows.Count).End(xlUp).Row
                   .Range("A" & lrow).Offset(1, 0).Value = olMail.Subject
                   .Range("A" & lrow).Offset(1, 1).Value = olMail.ReceivedTime
                   .Range("A" & lrow).Offset(1, 2).Value = olMail.SenderEmailAddress
                End With
            End If
            Next iCounter
        End If
    Next i
    Set olFolder = Nothing
Next eFolder

End Sub

当我调试并将鼠标悬停在最后几行时，似乎代码正在从Outlook正确提取信息。但是，我的工作表中没有填充提取的数据（电子邮件主题等）。根据我的收集情况，我已正确设置工作表变量，并不知道发生了什么。

感谢所有帮助

更新

现在正在填充工作表。我试图让代码通过一列电子邮件地址，并提取＆＃34;收到的时间＆＃34;如果地址与我的文件夹中的地址匹配，请从电子邮件中删除。

Answer 1

做了一些改变。看看这是否有效。

Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim eFolder As Outlook.folder
Dim i As Long
Dim x As Date
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long

Set wb = ActiveWorkbook
Set ws = wb.WorkSheets("Sheet1")

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = Date

'i think you want column E here, not L?
lastRow = ThisWorkbook.WorkSheets("Sheet1").Cells(Rows.Count, "L").End(xlUp).Row

For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.name)
For i = olFolder.Items.Count To 1 Step -1
For iCounter = 2 To lastRow
 If TypeOf olFolder.Items(i) Is MailItem Then
        Set olMail = olFolder.Items(i)
            If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then 'qualify the cell
                With ws
                   lrow = .Range("A" & .Rows.Count).End(xlUp).Row
                       .Range("A" & lrow + 1).Value = olMail.SUBJECT
                       .Range("B" & lrow + 1).Value = olMail.ReceivedTime
                       .Range("C" & lrow + 1).Value = olMail.SenderEmailAddress
                End With
            End If
            Next iCounter
        End If
    Next i
    Set olFolder = Nothing

Answer 2

您要在收件箱或子文件夹中查找的电子邮件是？代码只能查看收件箱中的每个文件夹，而不是查看实际的收件箱。

尝试以下更改：

Dim i As Long, j As Long 'Add "j as long"
'For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
For j = 0 To olNs.GetDefaultFolder(olFolderInbox).Folders.Count ' loop through the folders, starting at 0 (which we'll call the inbox)
    If j = 0 Then
        Set olFolder = olNs.GetDefaultFolder(olFolderInbox)
    Else
        Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(j)
    End If
...rest of loop
Next ' Remove 'efolder' from here

VBA代码未填充工作表

2 个答案: