Note: The other languages of the website are Google-translated. Back to English
Accedi  \/ 
x
or
x
Registrati  \/ 
x

or

Come copiare la struttura delle cartelle di Outlook sul desktop (Windows Explorer)?

Come sai, possiamo applicare la funzione Archivio per copiare la struttura delle cartelle su un altro Outlook, ma sai come copiare la struttura delle cartelle di Outlook in una determinata cartella della finestra, come il desktop? Questo articolo introdurrà un VBA per copiare facilmente la struttura delle cartelle di Outlook in Windows Explorer.

Copia la struttura delle cartelle di Outlook sul desktop (Windows Explorer)

Scheda Office: abilita la modifica a schede e la navigazione in Office e semplifica notevolmente il lavoro ...
Kutools for Outlook: porta 100 potenti funzionalità avanzate a Microsoft Outlook
  • Auto CC / BCC dalle regole durante l'invio di e-mail; Avanzamento automatico Email multiple per regole; Risposta automatica senza server di scambio e più funzioni automatiche ...
  • Avviso BCC - mostra il messaggio quando provi a rispondere a tutti se il tuo indirizzo di posta è nella lista BCC; Ricorda quando mancano allegatie altre funzioni di promemoria ...
  • Rispondi (tutti) con tutti gli allegati nella conversazione di posta; Rispondi a molte email contemporaneamente; Aggiunta automatica di saluto quando rispondi; Aggiungi automaticamente data e ora all'oggetto ...
  • Strumenti per gli allegati: Scollegamento automatico, Comprimi tutto, Rinomina tutto, Salva tutto automaticamente ... Rapporto rapido, Conta le email selezionate, Rimuovi messaggi e contatti duplicati ...
  • Più di 100 funzionalità avanzate lo faranno risolvi la maggior parte dei tuoi problemi in Outlook 2010-2019 e 365. Funzionalità complete Prova gratuita di 60 giorni.

Copia la struttura delle cartelle di Outlook sul desktop (Windows Explorer)

Seguire i passaggi seguenti per copiare la struttura delle cartelle di Outlook sul desktop o su Windows Explorer.

1. Nel riquadro di spostamento, fare clic per evidenziare la cartella specificata di cui si copierà la struttura di cartelle e premere altro + F11 tasti per aprire la finestra di Microsoft Visual Basic, Applications Edition.

2. Clic Strumenti > Referenze per aprire la finestra di dialogo Riferimenti. Quindi nella finestra di dialogo seleziona il file Runtime di script Microsoft opzione e fare clic su OK pulsante. Vedi screenshot:

3. Clic inserire > Moduloe copia e incolla sotto il codice VBA nella nuova finestra del modulo.

VBA: copia la struttura delle cartelle di Outlook in Windows Explorer

Dim xFSO As Scripting.FileSystemObject
Sub CopyOutlookFldStructureToWinExplorer()
    ExportAction "Copy"
End Sub
  
Sub ExportAction(xAction As String)
Dim xFolder As Outlook.Folder
Dim xFldPath As String
xFldPath = SelectAFolder()
If xFldPath = "" Then
    MsgBox "You did not select a folder. Export cancelled.", vbInformation + vbOKOnly, "Kutools for Outlook"
Else
    Set xFSO = New Scripting.FileSystemObject
    Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder
    ExportOutlookFolder xFolder, xFldPath
End If
Set xFolder = Nothing
Set xFSO = Nothing
End Sub

Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String)
Dim xSubFld As Outlook.Folder
Dim xItem As Object
Dim xPath As String
Dim xFilePath As String
Dim xSubject As String
Dim xCount As Integer
Dim xFilename As String
On Error Resume Next
xPath = xFldPath & "\" & OutlookFolder.Name
'?????????,??????
If Dir(xPath, 16) = Empty Then MkDir xPath
For Each xItem In OutlookFolder.Items
    xSubject = ReplaceInvalidCharacters(xItem.Subject)
    xFilename = xSubject & ".msg"
    xCount = 0
    xFilePath = xPath & "\" & xFilename
    If xFSO.FileExists(xFilePath) Then
        xCount = xCount + 1
        xFilename = xSubject & " (" & xCount & ").msg"
        xFilePath = xPath & "\" & xFilename
    End If
    xItem.SaveAs xFilePath, olMSG
Next
For Each xSubFld In OutlookFolder.Folders
    ExportOutlookFolder xSubFld, xPath
Next
Set OutlookFolder = Nothing
Set xItem = Nothing
End Sub

Function SelectAFolder() As String
Dim xSelFolder As Object
Dim xShell As Object
On Error Resume Next
Set xShell = CreateObject("Shell.Application")
Set xSelFolder = xShell.BrowseForFolder(0, "Select a folder", 0, 0)
If Not TypeName(xSelFolder) = "Nothing" Then
    SelectAFolder = xSelFolder.self.Path
End If
Set xSelFolder = Nothing
Set xShell = Nothing
End Function
  
Function ReplaceInvalidCharacters(Str As String) As String
Dim xRegEx
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
ReplaceInvalidCharacters = xRegEx.Replace(Str, "")
End Function

4. Stampa F5 o fare clic su Correre pulsante per eseguire questo VBA.

5. Nella finestra di dialogo Sfoglia per cartelle, selezionare la cartella specificata in cui inserire la struttura della cartella copiata e fare clic su OK pulsante. Vedi screenshot:

Ora vai alla cartella specificata, vedrai la struttura della cartella copiata sul disco rigido specificato. Vedi screenshot:

Note:: anche gli elementi della cartella, come e-mail, appuntamenti, attività, ecc. vengono copiati nelle cartelle corrispondenti del disco rigido.


Articoli Correlati


Kutools for Outlook: porta 100 funzionalità avanzate in Outlook e semplifica notevolmente il lavoro!

  • Auto CC / BCC dalle regole durante l'invio di e-mail; Avanzamento automatico Email multiple personalizzate; Risposta automatica senza server di scambio e più funzioni automatiche ...
  • Avviso BCC - mostra il messaggio quando provi a rispondere a tutti se il tuo indirizzo e-mail è nell'elenco BCC; Ricorda quando mancano allegatie altre funzioni di promemoria ...
  • Rispondi (tutti) con tutti gli allegati nella conversazione di posta; Rispondi a molte email in secondi; Aggiunta automatica di saluto quando rispondi; Aggiungi la data all'oggetto ...
  • Strumenti per gli allegati: gestisci tutti gli allegati in tutti i messaggi, Scollegamento automatico, Comprimi tutto, Rinomina tutto, Salva tutto ... Rapporto rapido, Conta le email selezionate...
  • E-mail spazzatura potenti per abitudine; Rimuovi messaggi e contatti duplicati... Consentono di fare in modo più intelligente, veloce e migliore in Outlook.
girato kutools outlook scheda kutools 1180x121
girato kutools outlook kutools plus tab 1180x121
 
Say something here...
symbols left.
You are guest
or post as a guest, but your post won't be published automatically.
Loading comment... The comment will be refreshed after 00:00.
  • To post as a guest, your comment is unpublished.
    Coco · 6 months ago
    Hello, that's brilliant! How can I adjust the code to only save email attachments, not the entire message? Many thanks
  • To post as a guest, your comment is unpublished.
    User2 · 1 years ago
    'This code solves the duplicate filename problem
    Dim xFSO As Scripting.FileSystemObject
    Sub CopyOutlookFldStructureToWinExplorer()
    ExportAction "Copy"
    End Sub

    Sub ExportAction(xAction As String)
    Dim xFolder As Outlook.Folder
    Dim xFldPath As String
    xFldPath = SelectAFolder()
    If xFldPath = "" Then
    MsgBox "You did not select a folder. Export cancelled.", vbInformation + vbOKOnly, "Kutools for Outlook"
    Else
    Set xFSO = New Scripting.FileSystemObject
    Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder
    ExportOutlookFolder xFolder, xFldPath
    End If
    Set xFolder = Nothing
    Set xFSO = Nothing
    End Sub

    Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String)
    Dim xSubFld As Outlook.Folder
    Dim xItem As Object
    Dim xPath As String
    Dim xFilePath As String
    Dim xSubject As String
    Dim xCount As Integer
    Dim xFilename As String
    On Error Resume Next
    xPath = xFldPath & "\" & OutlookFolder.Name
    '?????????,??????
    If Dir(xPath, 16) = Empty Then MkDir xPath

    xCount = 0

    For Each xItem In OutlookFolder.Items
    xSubject = ReplaceInvalidCharacters(xItem.Subject)
    xFilename = xSubject & ".msg"
    xFilePath = xPath & "\" & xFilename
    If xFSO.FileExists(xFilePath) Then
    xCount = xCount + 1
    xFilename = xSubject & " (" & xCount & ").msg"
    xFilePath = xPath & "\" & xFilename
    While xFSO.FileExists(xFilePath)
    xCount = xCount + 1
    xFilename = xSubject & " (" & xCount & ").msg"
    xFilePath = xPath & "\" & xFilename
    Wend
    End If
    xItem.SaveAs xFilePath, olMSG
    xCount = 0
    Next
    For Each xSubFld In OutlookFolder.Folders
    ExportOutlookFolder xSubFld, xPath
    Next
    Set OutlookFolder = Nothing
    Set xItem = Nothing
    End Sub

    Function SelectAFolder() As String
    Dim xSelFolder As Object
    Dim xShell As Object
    On Error Resume Next
    Set xShell = CreateObject("Shell.Application")
    Set xSelFolder = xShell.BrowseForFolder(0, "Select a folder", 0, 0)
    If Not TypeName(xSelFolder) = "Nothing" Then
    SelectAFolder = xSelFolder.self.Path
    End If
    Set xSelFolder = Nothing
    Set xShell = Nothing
    End Function

    Function ReplaceInvalidCharacters(Str As String) As String
    Dim xRegEx
    Set xRegEx = CreateObject("vbscript.regexp")
    xRegEx.Global = True
    xRegEx.IgnoreCase = False
    xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
    ReplaceInvalidCharacters = xRegEx.Replace(Str, "")
    End Function
  • To post as a guest, your comment is unpublished.
    SamTheCnt · 1 years ago
    Here is how i modified the code to make it work

    i will paste it in reply
    • To post as a guest, your comment is unpublished.
      SamTheCnt · 1 years ago
      Dim xFSO As Scripting.FileSystemObject
      Sub CopyOutlookFldStructureToWinExplorer()
      ExportAction "Copy"
      msg = MsgBox("Copy of your Inbox is successful", vbOKOnly, "Done")
      End Sub

      Sub ExportAction(xAction As String)
      Dim xFolder As Outlook.Folder
      Dim xFldPath As String
      xFldPath = SelectAFolder()
      If xFldPath = "" Then
      MsgBox "You did not select a folder. Export cancelled.", vbInformation + vbOKOnly, "Kutools for Outlook"
      Else
      Set xFSO = New Scripting.FileSystemObject
      Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder
      ExportOutlookFolder xFolder, xFldPath
      End If
      Set xFolder = Nothing
      Set xFSO = Nothing
      End Sub

      Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String)
      Dim xSubFld As Outlook.Folder
      Dim xItem As Object
      Dim xPath As String
      Dim xFilePath As String
      Dim xSubject As String * 100

      Dim xCounter As Integer
      Dim xFilename As String
      Dim xFileDateRec As String

      On Error Resume Next
      xPath = xFldPath & "\" & ReplaceInvalidCharacters(OutlookFolder.Name)

      If Dir(xPath, 16) = Empty Then MkDir xPath
      xCounter = 0

      For Each xItem In OutlookFolder.Items
      xCounter = xCounter + 1
      xSubject = ReplaceInvalidCharacters(xItem.Subject)
      xFileDateRec = xItem.ReceivedTime
      xFilename = ReplaceInvalidCharacters(RTrim(xSubject) & xFileDateRec & " " & xCounter & ".msg")
      xFilePath = xPath & "\" & xFilename
      xItem.SaveAs xFilePath, olMSG
      Next
      For Each xSubFld In OutlookFolder.Folders
      ExportOutlookFolder xSubFld, xPath
      Next
      Set OutlookFolder = Nothing
      Set xItem = Nothing
      End Sub

      Function SelectAFolder() As String
      Dim xSelFolder As Object
      Dim xShell As Object
      On Error Resume Next
      Set xShell = CreateObject("Shell.Application")
      Set xSelFolder = xShell.BrowseForFolder(0, "Select a folder", 0, 0)
      If Not TypeName(xSelFolder) = "Nothing" Then
      SelectAFolder = xSelFolder.self.Path
      End If
      Set xSelFolder = Nothing
      Set xShell = Nothing
      End Function

      Function ReplaceInvalidCharacters(Str As String) As String
      Dim xRegEx
      Set xRegEx = CreateObject("vbscript.regexp")
      xRegEx.Global = True
      xRegEx.IgnoreCase = False
      xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
      ReplaceInvalidCharacters = xRegEx.Replace(Str, "_")
      End Function
      • To post as a guest, your comment is unpublished.
        Adam · 1 years ago
        If I re-run this VBA every couple months, does it only copy new email or does it copy new email and create duplicates for all existing emails?

      • To post as a guest, your comment is unpublished.
        SamTheCnt · 1 years ago
        xItem.SaveAs xFilePath, olMSG
        Next
        For Each xSubFld In OutlookFolder.Folders
        ExportOutlookFolder xSubFld, xPath
        Next
        Set OutlookFolder = Nothing
        Set xItem = Nothing
        End Sub

        Function SelectAFolder() As String
        Dim xSelFolder As Object
        Dim xShell As Object
        On Error Resume Next
        Set xShell = CreateObject("Shell.Application")
        Set xSelFolder = xShell.BrowseForFolder(0, "Select a folder", 0, 0)
        If Not TypeName(xSelFolder) = "Nothing" Then
        SelectAFolder = xSelFolder.self.Path
        End If
        Set xSelFolder = Nothing
        Set xShell = Nothing
        End Function

        Function ReplaceInvalidCharacters(Str As String) As String
        Dim xRegEx
        Set xRegEx = CreateObject("vbscript.regexp")
        xRegEx.Global = True
        xRegEx.IgnoreCase = False
        xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
        ReplaceInvalidCharacters = xRegEx.Replace(Str, "_")
        End Function
        • To post as a guest, your comment is unpublished.
          ADam MIllar · 1 years ago
          What is this second piece of code? Do I use the original reply code or the second reply and that?

          • To post as a guest, your comment is unpublished.
            Sam · 1 years ago
            it is all 1 code, it was too long to post in 1 piece
  • To post as a guest, your comment is unpublished.
    acoli · 2 years ago
    hello, same thing. you code works great.. the only thing is that the duplicate names, more than (1), are not exported.
    Please add the option.
  • To post as a guest, your comment is unpublished.
    Romen · 2 years ago
    Yes! the same as Ammar asked, can you modify the code so it copies every item even if it has the same name!!! this would help me a lot
  • To post as a guest, your comment is unpublished.
    Ammar · 2 years ago
    Hello I have one question, I used the above mentioned code, but it is missing the related conversations as it has the same subject. This is created problem as the numbers of items in outlook not matching with number of items in folder. Can you please help to edit the above code so that it also paste all the items even though it has same subject ?
    • To post as a guest, your comment is unpublished.
      User · 1 years ago
      Dim xFSO As Scripting.FileSystemObject
      Sub CopyOutlookFldStructureToWinExplorer()
      ExportAction "Copy"
      End Sub

      Sub ExportAction(xAction As String)
      Dim xFolder As Outlook.Folder
      Dim xFldPath As String
      xFldPath = SelectAFolder()
      If xFldPath = "" Then
      MsgBox "You did not select a folder. Export cancelled.", vbInformation + vbOKOnly, "Kutools for Outlook"
      Else
      Set xFSO = New Scripting.FileSystemObject
      Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder
      ExportOutlookFolder xFolder, xFldPath
      End If
      Set xFolder = Nothing
      Set xFSO = Nothing
      End Sub

      Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String)
      Dim xSubFld As Outlook.Folder
      Dim xItem As Object
      Dim xPath As String
      Dim xFilePath As String
      Dim xSubject As String
      Dim xCount As Integer
      Dim xFilename As String
      On Error Resume Next
      xPath = xFldPath & "\" & OutlookFolder.Name
      '?????????,??????
      If Dir(xPath, 16) = Empty Then MkDir xPath
      xCount = 0 ' Pasted line
      For Each xItem In OutlookFolder.Items
      xSubject = ReplaceInvalidCharacters(xItem.Subject)
      xFilename = xSubject & ".msg"
      ' Deleted line xCount = 0
      xFilePath = xPath & "\" & xFilename
      If xFSO.FileExists(xFilePath) Then
      xCount = xCount + 1
      xFilename = xSubject & " (" & xCount & ").msg"
      xFilePath = xPath & "\" & xFilename
      Else ' New line
      xCount = 0 ' New line
      E
      xItem.SaveAs xFilePath, olMSG
      Next
      For Each xSubFld In OutlookFolder.Folders
      ExportOutlookFolder xSubFld, xPath
      Next
      Set OutlookFolder = Nothing
      Set xItem = Nothing
      End Sub

      Function SelectAFolder() As String
      Dim xSelFolder As Object
      Dim xShell As Object
      On Error Resume Next
      Set xShell = CreateObject("Shell.Application")
      Set xSelFolder = xShell.BrowseForFolder(0, "Select a folder", 0, 0)
      If Not TypeName(xSelFolder) = "Nothing" Then
      SelectAFolder = xSelFolder.self.Path
      End If
      Set xSelFolder = Nothing
      Set xShell = Nothing
      End Function

      Function ReplaceInvalidCharacters(Str As String) As String
      Dim xRegEx
      Set xRegEx = CreateObject("vbscript.regexp")
      xRegEx.Global = True
      xRegEx.IgnoreCase = False
      xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
      ReplaceInvalidCharacters = xRegEx.Replace(Str, "")
      End Function
  • To post as a guest, your comment is unpublished.
    Kristian · 2 years ago
    It works (sort of), but (a) there were more messages exported to one folder than were in the corresponding Outlook Folder and (b) there were fewer messages exported to one folder than were in the Outlook Folder and (c) (not 100% sure) I think one message went to the wrong folder.
  • To post as a guest, your comment is unpublished.
    Amy · 3 years ago
    I have Outlook 15, and the macro won't replace the "/" where used in Outlook folder names. It just skips those folders. Is this a compatibility issue?
  • To post as a guest, your comment is unpublished.
    and.infini@gmail.com · 3 years ago
    Bonjour,

    Serait-il possible de stocker les mails dans un fichier .pst ?

    D'avance merci pour vos retours.

    Cordialement,

    Ando Rakotomalala