Macro for attachments download adjustment

Status
Not open for further replies.

Martinoso

New Member
Outlook version
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
 
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.
 
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
 
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
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
Witzker Outlook 2019 Macro to answer a mail with attachments Outlook VBA and Custom Forms 2
L Macro/VBA to Reply All, with the original attachments Outlook VBA and Custom Forms 2
D Print Attachments only in selected emails using a macro Outlook VBA and Custom Forms 3
M VBA macro for Inbox's attachments search Outlook VBA and Custom Forms 0
D VBA macro printing attachments in shared mailbox Outlook VBA and Custom Forms 1
S macro for opening attachments and printing Using Outlook 1
O using macro to send attachments Using Outlook 3
L Macro Move E-mail attachments to a PC Folder Using Outlook 16
K Macro to insert attachments Using Outlook 1
M How do I make a macro that automatically adds attachments. Outlook VBA and Custom Forms 1
P Possible to write a macro to print all attachments with specific . Outlook VBA and Custom Forms 1
S how to disable security message in save attachments macro "A programis trying to access e-mail addre Outlook VBA and Custom Forms 5
X Custom icon (not from Office 365) for a macro in Outlook Outlook VBA and Custom Forms 1
X Run macro automatically when a mail appears in the sent folder Using Outlook 5
mrrobski68 Issue with Find messages in a conversation macro Outlook VBA and Custom Forms 1
G Creating Macro to scrape emails from calendar invite body Outlook VBA and Custom Forms 6
M Use Macro to change account settings Outlook VBA and Custom Forms 0
J Macro to Reply to Emails w/ Template Outlook VBA and Custom Forms 3
C Outlook - Macro to block senders domain - Macro Fix Outlook VBA and Custom Forms 1
Witzker Outlook 2019 Macro to seach in all contact Folders for marked Email Adress Outlook VBA and Custom Forms 1
S macro error 4605 Outlook VBA and Custom Forms 0
A Macro Mail Alert Using Outlook 4
J Outlook 365 Outlook Macro to Sort emails by column "Received" to view the latest email received Outlook VBA and Custom Forms 0
J Macro to send email as alias Outlook VBA and Custom Forms 0
M Outlook Macro to save as Email with a file name format : Date_Timestamp_Sender initial_Email subject Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro GoTo user defined search folder Outlook VBA and Custom Forms 6
D Outlook 2016 Creating an outlook Macro to select and approve Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro to send an Email Template from User Defined Contact Form Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro to check Cursor & Focus position Outlook VBA and Custom Forms 8
V Macro to mark email with a Category Outlook VBA and Custom Forms 4
M Outlook 2019 Macro not working Outlook VBA and Custom Forms 0
S Outlook 365 Help me create a Macro to make some received emails into tasks? Outlook VBA and Custom Forms 1
Geldner Send / Receive a particular group via macro or single keypress Using Outlook 1
D Auto Remove [EXTERNAL] from subject - Issue with Macro Using Outlook 21
V Macro to count flagged messages? Using Outlook 2
sophievldn Looking for a macro that moves completed items from subfolders to other subfolder Outlook VBA and Custom Forms 7
S Outlook Macro for [Date][Subject] Using Outlook 1
E Outlook - Macro - send list of Tasks which are not finished Outlook VBA and Custom Forms 3
E Macro to block senders domain Outlook VBA and Custom Forms 1
D VBA Macro to Print and Save email to network location Outlook VBA and Custom Forms 1
N VBA Macro To Save Emails Outlook VBA and Custom Forms 1
N Line to move origEmail to subfolder within a reply macro Outlook VBA and Custom Forms 0
A Outlook 2016 Macro to Reply, ReplyAll, or Forward(but with composing new email) Outlook VBA and Custom Forms 0
J Macro to Insert a Calendar Outlook VBA and Custom Forms 8
W Macro to Filter Based on Latest Email Outlook VBA and Custom Forms 6
T Macro to move reply and original message to folder Outlook VBA and Custom Forms 6
D Autosort macro for items in a view Outlook VBA and Custom Forms 2
S HTML to Plain Text Macro - Help Outlook VBA and Custom Forms 1
A Macro to file emails into subfolder based on subject line Outlook VBA and Custom Forms 1
N Help creating a VBA macro with conditional formatting to change the font color of all external emails to red Outlook VBA and Custom Forms 5

Similar threads

Back
Top