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

or

Hoe de Outlook-mapstructuur naar het bureaublad te kopiëren (Windows Verkenner)?

Zoals u weet, kunnen we de functie Archief toepassen om de mapstructuur naar een andere Outlook te kopiëren, maar weet u hoe u de Outlook-mapstructuur naar een bepaalde venstermap, zoals een bureaublad, kopieert? Dit artikel introduceert een VBA om de Outlook-mapstructuur eenvoudig naar Windows Verkenner te kopiëren.

Kopieer de Outlook-mapstructuur naar het bureaublad (Windows Verkenner)

Office-tabblad - Schakel bewerken en browsen met tabbladen in Office in en maak het werk veel gemakkelijker ...
Kutools for Outlook - Brengt 100 krachtige geavanceerde functies naar Microsoft Outlook
  • Auto CC / BCC volgens regels bij het verzenden van e-mail; Automatisch doorsturen Meerdere e-mails volgens regels; Auto antwoord zonder uitwisselingsserver, en meer automatische functies ...
  • BCC-waarschuwing - toon bericht wanneer u iedereen probeert te beantwoorden als uw e-mailadres in de BCC-lijst staat; Herinner bij ontbrekende bijlagen, en meer herinneren functies ...
  • Beantwoorden (alle) met alle bijlagen in het mailgesprek; Beantwoord veel e-mails tegelijk; Begroeting automatisch toevoegen wanneer antwoord; Datum en tijd automatisch toevoegen aan onderwerp ...
  • Hulpmiddelen voor bijlagen: Automatisch loskoppelen, alles comprimeren, alles hernoemen, alles automatisch opslaan ... Quick Report, Tel geselecteerde e-mails, Dubbele e-mails en contacten verwijderen ...
  • Meer dan 100 geavanceerde functies zullen los de meeste van uw problemen op in Outlook 2010-2019 en 365. Volledige gratis proefperiode van 60 dagen.

Kopieer de Outlook-mapstructuur naar het bureaublad (Windows Verkenner)

Volg onderstaande stappen om de Outlook-mapstructuur naar het bureaublad of Windows Verkenner te kopiëren.

1. Klik in het navigatiedeelvenster om de opgegeven map te markeren waarvan u de mapstructuur wilt kopiëren, en druk op anders + F11 -toetsen om het venster Microsoft Visual Basic for Applications te openen.

2. klikken Toolbox > Referenties om het dialoogvenster Verwijzingen te openen. Vink vervolgens in het dialoogvenster het Microsoft Scripting Runtime optie en klik op de OK knop. Zie screenshot:

3. klikken Invoegen > Module, en kopieer en plak onder VBA-code in het nieuwe modulevenster.

VBA: kopieer de Outlook-mapstructuur naar Windows Verkenner

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. druk op F5 toets of klik op de lopen knop om deze VBA uit te voeren.

5. Selecteer in het pop-upvenster Bladeren naar map de opgegeven map waarin u de gekopieerde mapstructuur wilt plaatsen en klik op de OK knop. Zie screenshot:

Ga nu naar de opgegeven map, u zult zien dat de mapstructuur naar de opgegeven harde schijf is gekopieerd. Zie screenshot:

Opmerking:: de mapitems, zoals e-mails, afspraken, taken, etc. worden ook gekopieerd naar overeenkomstige mappen op de harde schijf.


Gerelateerde artikelen


Kutools voor Outlook - Brengt 100 geavanceerde functies naar Outlook en maakt het werk veel gemakkelijker!

  • Auto CC / BCC volgens regels bij het verzenden van e-mail; Automatisch doorsturen Meerdere e-mails op maat; Auto antwoord zonder uitwisselingsserver, en meer automatische functies ...
  • BCC-waarschuwing - toon bericht wanneer u alle probeert te beantwoorden als uw e-mailadres in de BCC-lijst staat; Herinner bij ontbrekende bijlagen, en meer herinneren functies ...
  • Beantwoorden (alle) met alle bijlagen in het e-mailgesprek; Beantwoord veel e-mails in seconden; Begroeting automatisch toevoegen wanneer antwoord; Datum toevoegen aan onderwerp ...
  • Hulpmiddelen voor bijlagen: beheer alle bijlagen in alle e-mails, Automatisch loskoppelen, Alles comprimeren, Alles hernoemen, Alles opslaan ... Snel rapport, Tel geselecteerde e-mails...
  • Krachtige ongewenste e-mails op maat; Verwijder dubbele e-mails en contacten... Stel u in staat om slimmer, sneller en beter te doen in Outlook.
shot kutools outlook kutools tabblad 1180x121
shot kutools vooruitzichten kutools plus tabblad 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