Replicate Outlook Folder Structure and copy attachments to drive

B

Bering

Board Regular
Joined
Aug 22, 2018
Messages
185
Office Version
  1. 2016
Platform
  1. Windows
Hello,

I found a macro that copies Outlook folder structure to a selected folder and all folder items, such as emails, appointments, tasks, etc. are also copied into corresponding folders in the hard disc:

How to copy Outlook folder structure to desktop (windows explorer)?

I have been trying to modify the code in order to replicate the same folder structure in a selected folder, but I only need pdf email attachments in pdf containing certain strings in their name to be saved in the corresponding folders in the drive... no luck so far...

Below my attempt, thanks in advance

VBA Code: 
Option Explicit

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."
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 xAtt As Outlook.Attachments
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
If xAtt.Count <> 0 Then
For Each xAtt In xItem

If InStr(xItem.xAtt.DisplayName, ".pdf") Then
        If InStr(xItem.DisplayName, "Capital call", vbTextCompare) _
        Or InStr(xItem.DisplayName, "Drawdown", vbTextCompare) _
        Or InStr(xItem.DisplayName, "Distribution", vbTextCompare) _
        Or InStr(xItem.DisplayName, "Notice", vbTextCompare) Then

        xFilename = xAtt.DisplayName
        xCount = 0
        xFilePath = xPath & "\" & xFilename
'            If xFSO.FileExists(xFilePath) Then
'                xCount = xCount + 1
'                xFilename = xSubject & " (" & xCount & ").pdf"
'                xFilePath = xPath & "\" & xFilename
'            End If
        xItem.SaveAs xFilePath
        End If
End If

Next
End If
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
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Sort by date Sort by votes
Untested, but try changing:
VBA Code: 
If InStr(xItem.xAtt.DisplayName, ".pdf") Then
        If InStr(xItem.DisplayName, "Capital call", vbTextCompare) _
        Or InStr(xItem.DisplayName, "Drawdown", vbTextCompare) _
        Or InStr(xItem.DisplayName, "Distribution", vbTextCompare) _
        Or InStr(xItem.DisplayName, "Notice", vbTextCompare) Then

        xFilename = xAtt.DisplayName
to:
VBA Code: 
    xFilename = xAtt.DisplayName
    If InStr(xFilename, ".pdf", vbTextCompare) Then
        If InStr(xFilename, "Capital call", vbTextCompare) _
        Or InStr(xFilename, "Drawdown", vbTextCompare) _
        Or InStr(xFilename, "Distribution", vbTextCompare) _
        Or InStr(xFilename, "Notice", vbTextCompare) Then
 
Upvote 0
John_w said:
Untested, but try changing:
VBA Code: 
If InStr(xItem.xAtt.DisplayName, ".pdf") Then
        If InStr(xItem.DisplayName, "Capital call", vbTextCompare) _
        Or InStr(xItem.DisplayName, "Drawdown", vbTextCompare) _
        Or InStr(xItem.DisplayName, "Distribution", vbTextCompare) _
        Or InStr(xItem.DisplayName, "Notice", vbTextCompare) Then

        xFilename = xAtt.DisplayName
to:
VBA Code: 
    xFilename = xAtt.DisplayName
    If InStr(xFilename, ".pdf", vbTextCompare) Then
        If InStr(xFilename, "Capital call", vbTextCompare) _
        Or InStr(xFilename, "Drawdown", vbTextCompare) _
        Or InStr(xFilename, "Distribution", vbTextCompare) _
        Or InStr(xFilename, "Notice", vbTextCompare) Then

Thanks John, now it correctly replicates the structure of the selected Outlook folder, however it still does not save the attachments.
Click to expand...
 
Upvote 0
Also change these:
VBA Code: 
Dim xAtt As Outlook.Attachment

VBA Code: 
For Each xItem In OutlookFolder.Items

    For Each xAtt In xItem.Attachments

The If xAtt.Count <> 0 Then and its corresponding End If isn't needed because the For Each xAtt above should handle zero or more attachments.

I'd also comment out the On Error Resume Next, because it hides errors which you want to know about when coding.
 
Upvote 0
Really appreciate your help John, below is the modify code.

I still cannot get it to save the attachments within the folders... is there maybe something wrong in the if block or in this bit of code
Code: 
  xAtt.SaveAs xFilePath
?

Thank you

VBA Code: 
Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String)
Dim xSubFld As Outlook.Folder
Dim xItem As Object
Dim xAtt As Outlook.Attachment
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
For Each xAtt In xItem.Attachments
xFilename = xAtt.DisplayName
   xFilename = xAtt.DisplayName
    If InStr(xFilename, ".pdf") Then
        If InStr(xFilename, "Capital call") _
        Or InStr(xFilename, "Drawdown") _
        Or InStr(xFilename, "Distribution") _
        Or InStr(xFilename, "Notice") Then

        xFilePath = xPath & "\" & xFilename

        xAtt.SaveAs xFilePath
        End If
End If

Next

Next
For Each xSubFld In OutlookFolder.Folders
    ExportOutlookFolder xSubFld, xPath
Next
Set OutlookFolder = Nothing
Set xItem = Nothing
End Sub
 
Upvote 0
John_w said:
Also change these:
VBA Code: 
Dim xAtt As Outlook.Attachment

VBA Code: 
For Each xItem In OutlookFolder.Items

    For Each xAtt In xItem.Attachments

The If xAtt.Count <> 0 Then and its corresponding End If isn't needed because the For Each xAtt above should handle zero or more attachments.

I'd also comment out the On Error Resume Next, because it hides errors which you want to know about when coding.
Click to expand...

Bering said:
Really appreciate your help John, below is the modify code.

I still cannot get it to save the attachments within the folders... is there maybe something wrong in the if block or in this bit of code
Code: 
  xAtt.SaveAs xFilePath
?

Thank you

VBA Code: 
Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String)
Dim xSubFld As Outlook.Folder
Dim xItem As Object
Dim xAtt As Outlook.Attachment
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
For Each xAtt In xItem.Attachments
xFilename = xAtt.DisplayName
   xFilename = xAtt.DisplayName
    If InStr(xFilename, ".pdf") Then
        If InStr(xFilename, "Capital call") _
        Or InStr(xFilename, "Drawdown") _
        Or InStr(xFilename, "Distribution") _
        Or InStr(xFilename, "Notice") Then

        xFilePath = xPath & "\" & xFilename

        xAtt.SaveAs xFilePath
        End If
End If

Next

Next
For Each xSubFld In OutlookFolder.Folders
    ExportOutlookFolder xSubFld, xPath
Next
Set OutlookFolder = Nothing
Set xItem = Nothing
End Sub
Click to expand...

Forget that, I had accidentaly change
VBA Code: 
xItem.SaveAs xFilePath
to
Code: 
  xAtt.SaveAs xFilePath
.

Change it back an works like a charm.

Many thansk
 
Upvote 0
After running the macro I discovered that I can open none of the pdf saved :(

Anyone experienced this and knows how to fix it?

Thanks

1618818314521.png
 
Upvote 0
I rewrote the macro and added a few user-friendly features such as prompts and the ability to browse to and select the Outlook folder instead of using the current folder.

VBA Code: 
Option Explicit

Public Sub Copy_Outlook_Folders_To_Windows_Save_Attachments()

    Dim OutFolder As Outlook.Folder
    Dim WindowsFolder As String
    Dim OutNS As Outlook.NameSpace
   
    WindowsFolder = Select_Windows_Folder()
   
    If WindowsFolder = "" Then
   
        MsgBox "You did not select a Windows destination folder.  Export cancelled.", vbInformation + vbOKOnly, "Copy Outlook Folders"
       
    Else
   
        'Either: copy from current Outlook folder
        Set OutFolder = Outlook.Application.ActiveExplorer.CurrentFolder
       
        'Or: copy from selected Outlook folder
        'Set OutNS = Outlook.GetNamespace("MAPI")
        'Set OutFolder = OutNS.PickFolder
       
        If Not OutFolder Is Nothing Then
            If MsgBox("Copy Outlook " & OutFolder.folderPath & " folder and its subfolders to Windows " & WindowsFolder & "?", vbYesNo + vbQuestion, "Copy Outlook Folders") = vbYes Then
                If Right(WindowsFolder, 1) <> "\" Then WindowsFolder = WindowsFolder & "\"
                ExportOutlookFolders OutFolder, WindowsFolder
            End If
        End If
       
    End If
   
End Sub


Private Sub ExportOutlookFolders(ByVal OutFolder As Outlook.Folder, WindowsFolder As String)
   
    Dim OutSubFolder As Outlook.Folder
    Dim OutItem As Object
    Dim OutAttachment As Outlook.Attachment
    Dim outputPath As String
    Dim outputFilename As String
   
    outputPath = WindowsFolder & OutFolder.Name & "\"
    If Dir(outputPath, vbDirectory) = vbNullString Then MkDir outputPath
   
    For Each OutItem In OutFolder.Items
       
        For Each OutAttachment In OutItem.Attachments
            outputFilename = OutAttachment.DisplayName
            If InStr(1, outputFilename, ".pdf", vbTextCompare) Then
                If InStr(1, outputFilename, "Capital call", vbTextCompare) Or _
                   InStr(1, outputFilename, "Drawdown", vbTextCompare) Or _
                   InStr(1, outputFilename, "Distribution", vbTextCompare) Or _
                   InStr(1, outputFilename, "Notice", vbTextCompare) Then
                    Debug.Print "Saved: " & outputPath & outputFilename
                    OutAttachment.SaveAsFile outputPath & outputFilename
                End If
            End If
        Next
       
    Next
   
    'Recurse through subfolders of this Outlook folder
   
    For Each OutSubFolder In OutFolder.Folders
        ExportOutlookFolders OutSubFolder, outputPath
    Next
   
End Sub


Private Function Select_Windows_Folder() As String

    Dim WShell As Object
    Dim WShellFolder As Object
   
    Set WShell = CreateObject("Shell.Application")
    Set WShellFolder = WShell.BrowseForFolder(0, "Select Windows destination folder", 0, 0)
    If Not WShellFolder Is Nothing Then
        Select_Windows_Folder = WShellFolder.self.Path
    Else
        Select_Windows_Folder = ""
    End If
   
End Function
 
Upvote 0
Solution
John_w said:
I rewrote the macro and added a few user-friendly features such as prompts and the ability to browse to and select the Outlook folder instead of using the current folder.

VBA Code: 
Option Explicit

Public Sub Copy_Outlook_Folders_To_Windows_Save_Attachments()

    Dim OutFolder As Outlook.Folder
    Dim WindowsFolder As String
    Dim OutNS As Outlook.NameSpace
  
    WindowsFolder = Select_Windows_Folder()
  
    If WindowsFolder = "" Then
  
        MsgBox "You did not select a Windows destination folder.  Export cancelled.", vbInformation + vbOKOnly, "Copy Outlook Folders"
      
    Else
  
        'Either: copy from current Outlook folder
        Set OutFolder = Outlook.Application.ActiveExplorer.CurrentFolder
      
        'Or: copy from selected Outlook folder
        'Set OutNS = Outlook.GetNamespace("MAPI")
        'Set OutFolder = OutNS.PickFolder
      
        If Not OutFolder Is Nothing Then
            If MsgBox("Copy Outlook " & OutFolder.folderPath & " folder and its subfolders to Windows " & WindowsFolder & "?", vbYesNo + vbQuestion, "Copy Outlook Folders") = vbYes Then
                If Right(WindowsFolder, 1) <> "\" Then WindowsFolder = WindowsFolder & "\"
                ExportOutlookFolders OutFolder, WindowsFolder
            End If
        End If
      
    End If
  
End Sub


Private Sub ExportOutlookFolders(ByVal OutFolder As Outlook.Folder, WindowsFolder As String)
  
    Dim OutSubFolder As Outlook.Folder
    Dim OutItem As Object
    Dim OutAttachment As Outlook.Attachment
    Dim outputPath As String
    Dim outputFilename As String
  
    outputPath = WindowsFolder & OutFolder.Name & "\"
    If Dir(outputPath, vbDirectory) = vbNullString Then MkDir outputPath
  
    For Each OutItem In OutFolder.Items
      
        For Each OutAttachment In OutItem.Attachments
            outputFilename = OutAttachment.DisplayName
            If InStr(1, outputFilename, ".pdf", vbTextCompare) Then
                If InStr(1, outputFilename, "Capital call", vbTextCompare) Or _
                   InStr(1, outputFilename, "Drawdown", vbTextCompare) Or _
                   InStr(1, outputFilename, "Distribution", vbTextCompare) Or _
                   InStr(1, outputFilename, "Notice", vbTextCompare) Then
                    Debug.Print "Saved: " & outputPath & outputFilename
                    OutAttachment.SaveAsFile outputPath & outputFilename
                End If
            End If
        Next
      
    Next
  
    'Recurse through subfolders of this Outlook folder
  
    For Each OutSubFolder In OutFolder.Folders
        ExportOutlookFolders OutSubFolder, outputPath
    Next
  
End Sub


Private Function Select_Windows_Folder() As String

    Dim WShell As Object
    Dim WShellFolder As Object
  
    Set WShell = CreateObject("Shell.Application")
    Set WShellFolder = WShell.BrowseForFolder(0, "Select Windows destination folder", 0, 0)
    If Not WShellFolder Is Nothing Then
        Select_Windows_Folder = WShellFolder.self.Path
    Else
        Select_Windows_Folder = ""
    End If
  
End Function
Click to expand...
WOW, this is perfect!!! Thank you very much for your help!
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
VBA code to create a hyperlink from files in a folder and assign to a cell with a similar name
2
Replies
18
Views
3K
Domenic
D
M
  • Question
Mail merge: Excel to Word: How to change individual Names when splitting merged file
Replies
0
Views
538
MistaMista
M
C
  • Question
VBA attachments auto save help
Replies
0
Views
336
cxm687
C
M
  • Question
VBA Macro to Extract Outlook Attachment Excel Data and Paste into Specific Excel Worksheet Range
Replies
0
Views
568
mclawler
M
N
  • Solved
Sort emails in Outlook 365 folder, and loop through them opening the oldest first
Replies
7
Views
765
John_w
J

Forum statistics

Threads
1,214,925
Messages
6,122,301
Members
449,078
Latest member
nonnakkong

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top