Outlook VBA Importation de courriels à partir de sous-dossiers dans Excel


1

J'essaie d'importer les détails de chaque courriel (expéditeur, heure de réception, sujet etc.) dans ma boîte de réception dans un fichier Excel. J'ai le code qui fonctionne bien pour un dossier spécifique dans la boîte de réception, mais ma boîte de réception a plusieurs sous-dossiers, et ces sous-dossiers ont également des sous-dossiers. Après beaucoup d'essais et d'erreurs, j'ai réussi à importer les détails de tous les sous-dossiers sous la boîte de réception. Cependant, le code n'importe pas les courriels du 2e niveau des sous-dossiers et il ignore également les courriels qui se trouvent encore dans la boîte de réception. J'ai recherché ce site et d'autres, mais je ne trouve pas le code pour parcourir tous les dossiers et sous-dossiers d'une boîte de réception. Par exemple, j'ai une boîte de réception avec des sous-dossiers Rapports, Tarification et Projets. Le sous-dossier Report possède des sous-dossiers quotidiens, hebdomadaires et mensuels. Je peux importer les e-mails dans les rapports, mais pas dans les rapports quotidiens, hebdomadaires et mensuels.

Mon code tel qu'il est est ci-dessous:

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

Merci. J'ai utilisé le code donné dans le lien et il importe tout dans Outlook. Bien que cela soit utile, cela donne trop d'informations. J'espérais que je pourrais spécifier un dossier (tel que la boîte de réception) et importer tout de ceci et de ses sous-dossiers. Savez-vous s'il est possible de modifier le code ci-dessus pour y parvenir? 05 nov.. 152015-11-05 14:55:45

1

De cette question Can I iterate through all Outlook emails in a folder including sub-folders?

Remplacez votre tentative pour itérer les dossiers ...

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 

... en utilisant l'idée de récursion décrite dans la réponse actuellement acceptée.

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 

La deuxième réponse détaillée montre comment déclarer des variables en dehors du code pour transmettre des valeurs.

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