Outlook VBA Импорт электронной почты из подпапок в Excel


1

Я пытаюсь импортировать информацию о каждом письме (отправитель, полученное время, тема и т. Д.) В папку «Входящие» в файл Excel. У меня есть код, который отлично подходит для определенной папки в папке «Входящие», но у моей папки «Входящие» есть несколько подпапок, и эти подпапки также имеют подпапки.

После долгих проб и ошибок мне удалось импортировать данные обо всех подпапках под Inbox. Однако код не импортирует электронные письма из 2-го уровня подпапок, а также пропускает письма, которые все еще находятся в папке «Входящие». Я искал этот сайт и другие, но не могу найти код для прокрутки всех папок и подпапок папки «Входящие».

Например, у меня есть папка «Входящие» с подпапками «Отчеты, цены и проекты». Вложенная папка Report имеет подпапки, называемые Daily, Weekly и Monthly. Я могу импортировать сообщения в отчетах, но не в Daily, Weekly и Monthly.

Мой код, как он стоит ниже:

Sub SubFolders() 

Dim olMail As Variant 
Dim aOutput() As Variant 
Dim lCnt As Long 
Dim xlSh As Excel.Worksheet 
Dim olApp As Outlook.Application 
Dim olNs As Folder 
Dim olParentFolder As Outlook.MAPIFolder 
Dim olFolderA As Outlook.MAPIFolder 
Dim olFolderB As Outlook.MAPIFolder 

Set olApp = New Outlook.Application 
Set olNs = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 

Set olParentFolder = olNs 
ReDim aOutput(1 To 100000, 1 To 5) 

For Each olFolderA In olParentFolder.Folders 
    For Each olMail In olFolderA.Items 
    If TypeName(olMail) = "MailItem" Then 
    On Error Resume Next 
     lCnt = lCnt + 1 
     aOutput(lCnt, 1) = olMail.SenderEmailAddress 
     aOutput(lCnt, 2) = olMail.ReceivedTime 
     aOutput(lCnt, 3) = olMail.Subject 
     aOutput(lCnt, 4) = olMail.Sender 
     aOutput(lCnt, 5) = olMail.To 

    End If 
    Next 
Next 

Set xlApp = New Excel.Application 
Set xlSh = xlApp.Workbooks.Add.Sheets(1) 

xlSh.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput 
xlApp.Visible = True 

End Sub 
  0

Спасибо. Я использовал код, указанный в ссылке, и он импортирует все в Outlook. Хотя это полезно, он дает слишком много информации. Я надеялся, что я могу указать папку (например, «Входящие») и импортировать все из нее и ее подпапки. Знаете ли вы, можно ли изменить вышеуказанный код для достижения этого? 05 ноя. 152015-11-05 14:55:45

1

С этого вопроса Can I iterate through all Outlook emails in a folder including sub-folders?

Заменить попытку перебирать папки ...

For Each olFolderA In olParentFolder.Folders 
    For Each olMail In olFolderA.Items 
    If TypeName(olMail) = "MailItem" Then 
    On Error Resume Next 
     lCnt = lCnt + 1 
     aOutput(lCnt, 1) = olMail.SenderEmailAddress 
     aOutput(lCnt, 2) = olMail.ReceivedTime 
     aOutput(lCnt, 3) = olMail.Subject 
     aOutput(lCnt, 4) = olMail.Sender 
     aOutput(lCnt, 5) = olMail.To 
    End If 
    Next 
Next 

... используя идею рекурсии, описанной в принятом в настоящее время ответе.

Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder) 
    Dim oFolder As Outlook.MAPIFolder 
    Dim oMail As Outlook.MailItem 

    For Each oMail In oParent.Items 

    'Get your data here ... 

    Next 

    If (oParent.Folders.Count > 0) Then 
     For Each oFolder In oParent.Folders 
      processFolder oFolder ' <--- no brackets around oFolder 
     Next 
    End If 
End Sub 

Второй ответ показывает, как объявлять переменные за пределами кода для передачи значений.

Option Explicit 

Dim aOutput() As Variant 
Dim lCnt As Long 

Sub SubFolders() 
' 
' Code for Outlook versions 2007 and subsequent 
' Declare with Folder rather than MAPIfolder 
' 
Dim xlApp As Excel.Application 
Dim xlSh As Excel.Worksheet 

Dim olNs As Namespace 
Dim olParentFolder As Folder 

Set olNs = GetNamespace("MAPI") 
Set olParentFolder = olNs.GetDefaultFolder(olFolderInbox) 

lCnt = 0 
ReDim aOutput(1 To 100000, 1 To 5) 

ProcessFolder olParentFolder 

On Error Resume Next 
Set xlApp = GetObject(, "Excel.Application") 
On Error GoTo 0 
If xlApp Is Nothing Then Set xlApp = CreateObject("Excel.Application") 

Set xlSh = xlApp.Workbooks.Add.Sheets(1) 

xlSh.range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput 
xlApp.Visible = True 

ExitRoutine: 
    Set olNs = Nothing 
    Set olParentFolder = Nothing 
    Set xlApp = Nothing 
    Set xlSh = Nothing 

End Sub 

Private Sub ProcessFolder(ByVal oParent As Folder) 

Dim oFolder As Folder 
Dim oMail As Object 

For Each oMail In oParent.Items 

    If TypeName(oMail) = "MailItem" Then 
     lCnt = lCnt + 1 
     aOutput(lCnt, 1) = oMail.SenderEmailAddress 
     aOutput(lCnt, 2) = oMail.ReceivedTime 
     aOutput(lCnt, 3) = oMail.Subject 
     aOutput(lCnt, 4) = oMail.Sender 
     aOutput(lCnt, 5) = oMail.To 
    End If 

Next 

If (oParent.Folders.count > 0) Then 
    For Each oFolder In oParent.Folders 
     ProcessFolder oFolder 
    Next 
End If 

End Sub