Macro for attachments download adjustment

Status
Not open for further replies.

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
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
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
witzker Macro to move @domain.xx of a Spammail to Blacklist in Outlook 2019 Outlook VBA and Custom Forms 4
S Macro for other actions - Outlook 2007 Outlook VBA and Custom Forms 18
C Macro to extract sender name & subject line of incoming emails to single txt file Outlook VBA and Custom Forms 3
S Macro to move “Re:” & “FWD:” email recieved the shared inbox to a subfolder in outlook Outlook VBA and Custom Forms 0
S Outlook Macro to send auto acknowledge mail only to new mails received to a specific shared inbox Outlook VBA and Custom Forms 0
S Outlook Macro to move reply mail based on the key word in the subjectline Outlook VBA and Custom Forms 0
Eike Move mails via macro triggered by the click of a button? Outlook VBA and Custom Forms 0
S Macro or plug-in to see if specific person was included in this email Outlook VBA and Custom Forms 3
U Macro for reminders,tasks,calendar Outlook VBA and Custom Forms 4
V macro runs slower on startup than after Outlook VBA and Custom Forms 3
N Macro to move all recipients to CC while replying Outlook VBA and Custom Forms 0
A VBA macro for 15 second loop in send and received just for 1 specific mailbox Outlook VBA and Custom Forms 1
G VBA Macro Calendar Printing Assistant 4
R Help Revising VBA macro to delete email over different time span Outlook VBA and Custom Forms 0
M Outlook macro to automate search and forward process Outlook VBA and Custom Forms 6
R Macro Schedule every day in Outlook Using Outlook 0
L Moving emails with similar subject and find the timings between the emails using outlook VBA macro Outlook VBA and Custom Forms 1
Healy Consultants Macro to remove inside organization distribution list email address when reply to all recepients Outlook VBA and Custom Forms 0
geofferyh Cannot get Macro to SAVE more than one message attachment??? Outlook VBA and Custom Forms 5
N How can I increase/faster outlook VBA Macro Speed ? Using Outlook 2
4 Macro to set the category of Deleted Item? Outlook VBA and Custom Forms 2
D.Moore Folder view settings by VBA macro Outlook VBA and Custom Forms 57
A Outlook macro to create search folder with mail categories as criteria Outlook VBA and Custom Forms 3
Dave A Run macro on existing appointment when it changes Outlook VBA and Custom Forms 1
V Outlook Macro to show Flagged messages Outlook VBA and Custom Forms 2
O Run macro automatically at sending an email Using Outlook 11
R Retain Original Message When Forwarding With Macro Outlook VBA and Custom Forms 3
C Macro to add multiple recipients to message Outlook VBA and Custom Forms 3
B Reply and replyall macro is not working Outlook VBA and Custom Forms 1
O Macro - paste as plain text Outlook VBA and Custom Forms 2
J Help Please!!! Outlook 2016 - VBA Macro for replying with attachment in meeting invite Outlook VBA and Custom Forms 9
witzker Macro to set contact reminder to next day 9:00 Outlook VBA and Custom Forms 45
M Adding Macro to populate "to" "subject" "body" not deleting email string below. Outlook VBA and Custom Forms 5
E Copying data from e-mail attachement to EXCEL file via macro Outlook VBA and Custom Forms 38
M Macro to add date/time stamp to subject Outlook VBA and Custom Forms 4
R VBA macro - new message Outlook VBA and Custom Forms 3
S Example VBA Macro - To Conditionally Change the From Account and Add a BCC Address on Emails Outlook VBA and Custom Forms 11
S Macro using .SendUsingAccount only works the first time, after starting Outlook Outlook VBA and Custom Forms 4
S VBA Macro - Run-time error '424': object required - Help Please Outlook VBA and Custom Forms 3

Similar threads

Top