Comment exporter tous les e-mails forment un dossier spécifique d'Outlook à Excel

Question

J'ai une macro qui exporte toutes les données à partir de Outlook INBOX vers Excel avec l'heure et la date, mais j'ai besoin de configurer un dossier particulier pour être copié dans un de la même façon.

Comment puis-je configurer un sous-dossier spécifique?

Option Explicit 
Sub CopyToExcel() 
    Dim xlApp As Object 
    Dim xlWB As Object 
    Dim xlSheet As Object 
    Dim rCount As Long 
    Dim bXStarted As Boolean 
    Dim enviro As String 
    Dim strPath As String 
    Dim objOL As Outlook.Application 
    Dim objFolder As Outlook.MAPIFolder 
    Dim objItems As Outlook.Items 
    Dim obj As Object 
    Dim olItem 'As Outlook.MailItem 
    Dim strColA, strColB, strColC, strColD, strColE, strColF As String 

    ' Get Excel set up 
    enviro = CStr(Environ("USERPROFILE")) 

    'the path of the workbook 
    strPath = enviro & "\Documents\Book1.xlsx" 

    On Error Resume Next 
    Set xlApp = GetObject(, "Excel.Application") 

    If Err <> 0 Then 
     Application.StatusBar = "Please wait while Excel source is opened ... " 
      Set xlApp = CreateObject("Excel.Application") 
     bXStarted = True 
    End If 
    On Error GoTo 0 

    On Error Resume Next 
    ' Open the workbook to input the data 
    ' Create workbook if doesn't exist 
    Set xlWB = xlApp.Workbooks.Open(strPath) 
    If Err <> 0 Then 
     Set xlWB = xlApp.Workbooks.Add 
     xlWB.SaveAs FileName:=strPath 
    End If 
    On Error GoTo 0 

    Set xlSheet = xlWB.Sheets("Sheet1") 

    On Error Resume Next 
    ' add the headers if not present 
    If xlSheet.Range("A1") = "" Then 
     xlSheet.Range("A1") = "Sender Name" 
     xlSheet.Range("B1") = "Sender Email" 
     xlSheet.Range("C1") = "Subject" 
     xlSheet.Range("D1") = "Body" 
     xlSheet.Range("E1") = "Sent To" 
     xlSheet.Range("F1") = "Date" 
    End If 

    'Find the next empty line of the worksheet 
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row 

    ' needed for Exchange 2016. Remove if causing blank lines. 
    rCount = rCount + 1 

    ' get the values from outlook 
    Set objOL = Outlook.Application 
    Set objFolder = objOL.ActiveExplorer.CurrentFolder 
    Set objItems = objFolder.Items 

    For Each obj In objItems 
     Set olItem = obj 

     'collect the fields 
     strColA = olItem.SenderName 
     strColB = olItem.SenderEmailAddress 
     strColC = olItem.Subject 
     strColD = olItem.Body 
     strColE = olItem.To 
     strColF = olItem.ReceivedTime 


     ' Get the Exchange address 
     ' if not using Exchange, this block can be removed 
     Dim olEU As Outlook.ExchangeUser 
     Dim oEDL As Outlook.ExchangeDistributionList 
     Dim recip As Outlook.Recipient 

     Set recip = Application.Session.CreateRecipient(strColB) 

     If InStr(1, strColB, "/") > 0 Then 
      ' if exchange, get smtp address 
      Select Case recip.AddressEntry.AddressEntryUserType 
       Case OlAddressEntryUserType.olExchangeUserAddressEntry 
       Set olEU = recip.AddressEntry.GetExchangeUser 

       If Not (olEU Is Nothing) Then 
        strColB = olEU.PrimarySmtpAddress 
       End If 

       Case OlAddressEntryUserType.olOutlookContactAddressEntry 
        Set olEU = recip.AddressEntry.GetExchangeUser 

        If Not (olEU Is Nothing) Then 
         strColB = olEU.PrimarySmtpAddress 
        End If 

       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry 
        Set oEDL = recip.AddressEntry.GetExchangeDistributionList 

        If Not (oEDL Is Nothing) Then 
         strColB = olEU.PrimarySmtpAddress 
        End If 
      End Select 
     End If 
     ' End Exchange section 

     'write them in the excel sheet 
     xlSheet.Range("A" & rCount) = strColA 
     xlSheet.Range("B" & rCount) = strColB 
     xlSheet.Range("c" & rCount) = strColC 
     xlSheet.Range("d" & rCount) = strColD 
     xlSheet.Range("e" & rCount) = strColE 
     xlSheet.Range("f" & rCount) = strColF 

     'Next row 
     rCount = rCount + 1 
     xlWB.Save 
    Next 

    ' don't wrap lines 
    xlSheet.Rows.WrapText = False 

    xlWB.Save 
    xlWB.Close 1 
    If bXStarted Then 
     xlApp.Quit 
    End If 

    Set olItem = Nothing 
    Set obj = Nothing 
    Set xlApp = Nothing 
    Set xlWB = Nothing 
    Set xlSheet = Nothing 
End Sub 

Answer 1

Vous utilisez ActiveExplorer.CurrentFolder sur votre code, le CurrentFolder Property représente le dossier en cours qui est affiché dans l'explorateur, le code devrait fonctionner sur tout Active Explorer - il suffit de naviguer sur un dossier que vous souhaitez exécuter le code sur.

Si vous préférez changer alors vous devez modifier les lignes de code suivantes pour configurer votre dossier spécifié,

' get the values from outlook 
Set objOL = Outlook.Application 
Set objFolder = objOL.ActiveExplorer.CurrentFolder 

Pour quelque chose comme ça

' get the values from outlook 
Set objOL = Outlook.Application 
Dim olNs As Outlook.NameSpace 
Set olNs = objOL.GetNamespace("MAPI") 
Set objFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("SubFolder Name Here") 

_{Voir Folder Object (Outlook) MSDN Utilisez la propriété Dossiers d'un objet NameSpace ou d'un autre objet Dossier pour renvoyer l'ensemble de dossiers dans un espace de nom ou dans un dossier. Vous pouvez naviguer dans les dossiers imbriqués en partant d'un dossier de niveau supérieur, par exemple la boîte de réception, et en utilisant une combinaison de la propriété Folder.Folders, qui retourne l'ensemble des dossiers en dessous d'un objet dossier dans la hiérarchie,}

Exemple:

GetDefaultFolder(olFolderInbox).Folders("SubFolderName") _ 
           .Folders("SubFolderName") 

_{et la méthode de Folders.Item, qui renvoie un dossier au sein de la collection des dossiers.}