Macro for attachments download adjustment

Martinoso

New Member
Outlook version
Outlook 2007
Email Account
Outlook.com (as MS Exchange)
Hello,
I have a macro called GetEmailAttachments, which I use for downloading all attachments from Inbox to My Documents. I have also created a second one for the purpose of attachments from my Sub Folder. Problem is, that 2nd macro is not downloading all of the attachments from my Sub Folders and I wonder why is that. Additionally, is that possible to enhance the loop for the macro to search all Sub Folders within Sub Folder? Many thanks.
Code:
Option Explicit

'References : Microsoft Outlook 16.0 Object Library
'--------------------------------------------------

Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Const NoError = 0

Sub GetEmailAttachments()

    On Error Resume Next

    Dim ns              As NameSpace
    Dim Inbox           As MAPIFolder
    Dim Item            As Object
    Dim atmt            As attachment
    Dim fileName        As String
    Dim i               As Long
    Dim itemsCount      As Long
    Dim x               As Long
    Dim pct             As Single
  
    ufProgress.LabelProgress.Width = 0
    ufProgress.Show


    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    i = 0
    itemsCount = Inbox.Items.Count

    If itemsCount = 0 Then
        ufProgress.hide
        MsgBox "There are no valid messages in the Inbox.", vbInformation, "Nothing Found"
        Exit Sub
    End If
  
    For Each Item In Inbox.Items
        '>> Added This Portion
        '=====================
        x = x + 1
        pct = x / itemsCount
      
        With ufProgress
            .LabelCaption.Caption = "Processing Email " & x & " Of " & itemsCount
            .LabelProgress.Width = pct * (.FrameProgress.Width)
        End With
        DoEvents
        '=====================
        For Each atmt In Item.Attachments
            If Right(atmt.fileName, 3) = "pdf" Or Right(atmt.fileName, 3) = "jpg" And atmt.Size > 45000 Then
                If fileName = "" Then
                    Call CreateFolder
                End If

                fileName = MyDocs() & Item.SenderName & " " & atmt.fileName
                atmt.SaveAsFile fileName
                i = i + 1
            End If
        Next atmt

        If x = itemsCount Then Unload ufProgress
    Next Item

    If i > 0 Then
        MsgBox "There are " & i & " attached files found." & vbCrLf & "They were saved into the Email Attachments folder in My Documents.", vbInformation, "Finished!"
    Else
        MsgBox "There are no attached files in your Inbox.", vbInformation, "Finished!"
    End If
  
GetAttachments_exit:
    Set atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
  
  
'Use On Error Resume Next as some of the attachments types might be causing an error
GetAttachments_err:
    MsgBox "An Unexpected Error Has Occurred." _
         & vbCrLf & "Please Note And Report The Following Information." _
         & vbCrLf & "Macro Name: GetEmailAttachments" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume GetAttachments_exit
End Sub

Function GetUserName()
    Const lpnLength     As Integer = 255
    Dim status          As Integer
    Dim lpName          As String
    Dim lpUserName      As String

    lpUserName = Space$(lpnLength + 1)
    status = WNetGetUser(lpName, lpUserName, lpnLength)

    If status = NoError Then
        lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
    Else
        MsgBox "Unable To Get The Name", vbExclamation
        End
    End If
  
    GetUserName = lpUserName
End Function

Function MyDocs() As String
    Dim strStart        As String
    Dim strEnd          As String
    Dim strUser         As String

    strUser = GetUserName()
    strStart = "C:\Documents and Settings\"
    strEnd = "\My Documents\Email Attachments\"

    MyDocs = strStart & strUser & strEnd
End Function

Private Sub CreateFolder()
    Dim wsh             As Object
    Dim fs              As Object
    Dim destFolder      As String
    Dim myDocPath       As String

    If destFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
      
        myDocPath = wsh.SpecialFolders.Item("mydocuments")
        destFolder = myDocPath & "\Email Attachments"
      
        If Not fs.FolderExists(destFolder) Then
            fs.CreateFolder destFolder
        End If
    End If
End Sub
And here's the second macro (the one, which is not downloading all attachments)

Code:
Option Explicit

'References : Microsoft Outlook 16.0 Object Library
'--------------------------------------------------

Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Const NoError = 0

Sub GetEmailAttachments2()

    On Error Resume Next

    Dim ns              As NameSpace
    Dim Inbox           As MAPIFolder
    Dim Item            As Object
    Dim atmt            As attachment
    Dim fileName        As String
    Dim i               As Long
    Dim itemsCount      As Long
    Dim x               As Long
    Dim pct             As Single
    Dim SubFolder       As MAPIFolder
    Dim OutlookFolderInInbox As String
  
    ufProgress.LabelProgress.Width = 0
    ufProgress.Show


    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(olFolderInbox)

    i = 0
    itemsCount = SubFolder.Items.Count

    If itemsCount = 0 Then
        ufProgress.hide
        MsgBox "There are no messages in the Sub Folders.", vbInformation, "Nothing Found"
        Exit Sub
    End If
  
    For Each Item In SubFolder.Items
        '>> Added This Portion
        '=====================
        x = x + 1
        pct = x / itemsCount
      
        With ufProgress
            .LabelCaption.Caption = "Processing Email " & x & " Of " & itemsCount
            .LabelProgress.Width = pct * (.FrameProgress.Width)
        End With
        DoEvents
        '=====================

        For Each atmt In Item.Attachments
            If Right(atmt.fileName, 3) = "pdf" Or Right(atmt.fileName, 3) = "jpg" And atmt.Size > 45000 Then
                    If fileName = "" Then
                    Call CreateFolder2
                    End If

                fileName = MyDocs2() & Item.SenderName & " " & atmt.fileName
                atmt.SaveAsFile fileName
                i = i + 1
            End If
            Next atmt


        If x = itemsCount Then Unload ufProgress
    Next Item

    If i > 0 Then
        MsgBox "There are " & i & " attached files found." & vbCrLf & "They were saved into the Email Attachments folder in My Documents.", vbInformation, "Finished!"
    Else
        MsgBox "There are no attached files in your Inbox.", vbInformation, "Finished!"
    End If
  
GetAttachments_exit:
    Set atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
  
  
'Use On Error Resume Next as some of the attachments types might be causing an error
GetAttachments_err:
    MsgBox "An Unexpected Error Has Occurred." _
         & vbCrLf & "Please Note And Report The Following Information." _
         & vbCrLf & "Macro Name: GetEmailAttachments" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume GetAttachments_exit
End Sub

Function GetUserName()
    Const lpnLength     As Integer = 255
    Dim status          As Integer
    Dim lpName          As String
    Dim lpUserName      As String

    lpUserName = Space$(lpnLength + 1)
    status = WNetGetUser(lpName, lpUserName, lpnLength)

    If status = NoError Then
        lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
    Else
        MsgBox "Unable To Get The Name", vbExclamation
        End
    End If
  
    GetUserName = lpUserName
End Function

Function MyDocs2() As String
    Dim strStart        As String
    Dim strEnd          As String
    Dim strUser         As String

    strUser = GetUserName()
    strStart = "C:\Documents and Settings\"
    strEnd = "\My Documents\Email Attachments SubFolders\"

    MyDocs2 = strStart & strUser & strEnd
End Function

Private Sub CreateFolder2()
    Dim wsh             As Object
    Dim fs              As Object
    Dim destFolder      As String
    Dim myDocPath       As String

    If destFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
      
        myDocPath = wsh.SpecialFolders.Item("mydocuments")
        destFolder = myDocPath & "\Email Attachments SubFolders"
      
        If Not fs.FolderExists(destFolder) Then
            fs.CreateFolder destFolder
        End If
    End If
End Sub
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
On the second one - Set SubFolder = Inbox.Folders(olFolderInbox) should be Set SubFolder = Inbox.Folders("folder name")
to walk the folders, you need to use a loop to get each folder name, run the macro to save, then loop to the next folder. you'd call the folder using a variable:
Set SubFolder = Inbox.Folders(strFolderName)

this example shows how to walk the folders - Print a list of your Outlook folders - you'll need to work the sub ProcessFolder into your script.
 

Martinoso

New Member
Outlook version
Outlook 2007
Email Account
Outlook.com (as MS Exchange)
Thank you very much for the link and insights. I have amended my VBA code, however the macro seems to be working fine but only for 1 selected Sub Folder + all Sub Folders within. I am not sure why it's not looping through all Sub Folder staring from the selected one.

Code:
Option Explicit

Public strFolders As String
'References : Microsoft Outlook 16.0 Object Library
'--------------------------------------------------

Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Const NoError = 0

Sub GetEmailAttachments2()

    On Error Resume Next

    Dim ns                      As NameSpace
    Dim Inbox                   As MAPIFolder
    Dim Item                    As Object
    Dim atmt                    As attachment
    Dim fileName                As String
    Dim i                       As Long
    Dim itemsCount              As Long
    Dim x                       As Long
    Dim pct                     As Single
    Dim SubFolder               As MAPIFolder
    Dim OutlookFolderInInbox    As String
    Dim olStartFolder           As Outlook.MAPIFolder
    Dim olSession               As Outlook.NameSpace
    Dim olApp                   As Outlook.Application
    Dim lCountOfFound           As Long
    Dim olNewFolder             As Outlook.MAPIFolder
    Dim olTempFolder            As Outlook.MAPIFolder
    Dim olTempFolderPath        As String
    Dim CurrentFolder           As Outlook.MAPIFolder
    Dim olCount                 As Long
   
    lCountOfFound = 0
   
    Set olApp = New Outlook.Application
    Set olSession = olApp.GetNamespace("MAPI")
    Set SubFolder = olSession.PickFolder
   
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    'Set SubFolder = Inbox.Folders(olFolderInbox)
   
    'ufProgress.LabelProgress.Width = 0
    'ufProgress.Show

    'i = 0
    lCountOfFound = olTempFolder.Items.Count

    'If lCountOfFound = 0 Then
        'ufProgress.hide
        'MsgBox "There are no messages in the Sub Folders.", vbInformation, "Nothing Found"
        'Exit Sub
    'End If
   
    For i = SubFolder.Folders.Count To 1 Step -1
        Set olTempFolder = SubFolder.Folders(i)
        olTempFolderPath = olTempFolder.FolderPath

        i = 0
        olCount = olTempFolder.Items.Count
   
        For Each olTempFolder In SubFolder.Folders
            For Each Item In olTempFolder.Items
        '>> Progress Bar
        '=====================
        'i = i + 1
        'pct = i / lCountOfFound
       
        'With ufProgress
            '.LabelCaption.Caption = "Processing Email " & i & " Of " & lCountOfFound
            '.LabelProgress.Width = pct * (.FrameProgress.Width)
        'End With
        'DoEvents
        '=====================

        For Each atmt In Item.Attachments
            If Right(atmt.fileName, 3) = "pdf" Or Right(atmt.fileName, 3) = "jpg" And atmt.Size > 45000 Or Right(atmt.fileName, 3) = "JPG" And atmt.Size > 45000 Then
                    If fileName = "" Then
                    Call CreateFolder2
                    End If

                fileName = MyDocs2() & Item.SenderName & " " & atmt.fileName
                atmt.SaveAsFile fileName
                i = i + 1
            End If
            Next atmt


        'If i = lCountOfFound Then Unload ufProgress
        Next Item
        lCountOfFound = lCountOfFound + 1
        Next
        Next
   
    'If i = lCountOfFound Then Unload ufProgress
   
    strFolders = ""

    If i > 0 Then
        MsgBox "There are " & i & " attached files found." & vbCrLf & "They were saved into the Email Attachments folder in My Documents.", vbInformation, "Finished!"
    Else
        MsgBox "There are no attached files in your Inbox.", vbInformation, "Finished!"
    End If
   
   
GetAttachments_exit:
    Set atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
   
   
'Use On Error Resume Next as some of the attachments types might be causing an error
GetAttachments_err:
    MsgBox "An Unexpected Error Has Occurred." _
         & vbCrLf & "Please Note And Report The Following Information." _
         & vbCrLf & "Macro Name: GetEmailAttachments" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume GetAttachments_exit
End Sub

Function GetUserName()
    Const lpnLength     As Integer = 255
    Dim status          As Integer
    Dim lpName          As String
    Dim lpUserName      As String

    lpUserName = Space$(lpnLength + 1)
    status = WNetGetUser(lpName, lpUserName, lpnLength)

    If status = NoError Then
        lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
    Else
        MsgBox "Unable To Get The Name", vbExclamation
        End
    End If
   
    GetUserName = lpUserName
End Function

Function MyDocs2() As String
    Dim strStart        As String
    Dim strEnd          As String
    Dim strUser         As String

    strUser = GetUserName()
    strStart = "C:\Documents and Settings\"
    strEnd = "\My Documents\Email Attachments SubFolders\"

    MyDocs2 = strStart & strUser & strEnd
End Function

Private Sub CreateFolder2()
    Dim wsh             As Object
    Dim fs              As Object
    Dim destFolder      As String
    Dim myDocPath       As String

    If destFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
       
        myDocPath = wsh.SpecialFolders.Item("mydocuments")
        destFolder = myDocPath & "\Email Attachments SubFolders"
       
        If Not fs.FolderExists(destFolder) Then
            fs.CreateFolder destFolder
        End If
    End If
End Sub
 

noobie

Member
Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server 2013
Hey, I am working on a similar project and I also encountered your problem.

I solved it the following way:

1) select the parent folder
2) do all the stuff you want for the parent folder
3) loop recursively through the subfolders and do all the stuff for your subfolders


Code:
' In your main sub

Set ParentFolder = olApp.ActiveExplorer.CurrentFolder

Call GetStuffDone('variables')
' or simply do all the steps you want to do here

Call LoopFolders(ParentFolder, 'other varibales', True)

Code:
Function LoopFolders(SelectedFolder As Outlook.MAPIFolder, 'other variables', ByVal Recursive As Boolean)

' SelectedFolder = ParentFolder = olApp.ActiveExplorer.CurrentFolder

' Declare any constants here
 
Dim SelectedSubfolder As Outlook.MAPIFolder
' Plus any other variables you need
 
  For Each SelectedSubfolder In SelectedFolder.Folders

' Now have the same stuff done for your subfolders as for your parent folder
    Call GetStuffDone('variables')
   ' or simply do all the steps you want to do here
  
    If Recursive Then
      Call LoopFolders(SelectedSubfolder, 'other varibales' , Recursive)
    End If
 
  Next
 
Set selSubfolder = Nothing
 
End Function
 
Top