Outlook Macro Save Only PDF Attachments and mark Email as read

Newfie

New Member
Joined
Jul 17, 2012
Messages
7
Hi

I’m new to VBA and I really have no idea what I’m doing so here I am looking for help from the pro’s

I found this script online and though it would be useful, I made some changes to it however I’m having issues getting it to do exactly what I want.

The below works to a point, it will save all PDF attachments to c:\test\, mark the emails as read, if there is no attachment it will keep the email as unread, however if there are any other attachments xlxs, docx. txt, etc……. it does not save them(which it what I want) but it marks the email as read(which I do not want) I only want emails with PDF to be marked as read.


Sub SaveAttachments()

Dim myOlapp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
Dim myAttachment As Outlook.Attachment
Dim avDate() As String
Dim vDate As String
Dim i As Long

Const myPath As String = "C:\test\"

ReDim Preserve avDate(3)

Set myOlapp = CreateObject("Outlook.Application")
Set myNameSpace = myOlapp.GetNamespace("MAPI")

Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)

For Each myItem In myFolder.Items
If myItem.UnRead = True Then
avDate = Split(CStr(myItem.ReceivedTime), "/")


vDate = Mid(avDate(2), 1, 4) & "-" & avDate(1) & "-" & avDate(0)
If myItem.Attachments.Count <> 0 Then
For Each myAttachment In myItem.Attachments

If UCase(Right(myAttachment.FileName, 3)) = "PDF" Then
i = i + 1
myAttachment.SaveAsFile (myPath & vDate & " - " & i & " - " & _
myAttachment.FileName)

End If
Next
myItem.UnRead = False
End If
End If
Next

End Sub
 

AD_Taylor

Well-known Member
Joined
May 19, 2011
Messages
687
You could try something like this. I've introduced a new variable that keeps a count of how many PDFs were found in the current item. Then if that count is greater than 0 the item is marked unread.

Code:
Sub SaveAttachments()
    Dim myOlapp         As Outlook.Application
    Dim myNameSpace     As Outlook.Namespace
    Dim myFolder        As Outlook.MAPIFolder
    Dim myItem          As Outlook.MailItem
    Dim myAttachment    As Outlook.Attachment
    Dim avDate()        As String
    Dim vDate           As String
    Dim i               As Long
    
    Dim PDFCount        As Long
    
    Const myPath As String = "C:\test\"
    ReDim Preserve avDate(3)
    
    Set myOlapp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlapp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
    
    For Each myItem In myFolder.Items
        PDFCount = 0
        
        If myItem.UnRead = True Then
            avDate = Split(CStr(myItem.ReceivedTime), "/")
            vDate = Mid(avDate(2), 1, 4) & "-" & avDate(1) & "-" & avDate(0)
            
            If myItem.Attachments.Count <> 0 Then
                For Each myAttachment In myItem.Attachments
                    If UCase(Right(myAttachment.Filename, 3)) = "PDF" Then
                        i = i + 1
                        PDFCount = PDFCount + 1
                        myAttachment.SaveAsFile (myPath & vDate & " - " & i & " - " & _
                        myAttachment.Filename)
                    End If
                Next myAttachment
                
                If PDFCount > 0 Then
                    myItem.UnRead = False
                End If
            End If
        End If
    Next myItem
End Sub
 

Newfie

New Member
Joined
Jul 17, 2012
Messages
7
Thanks for the quick reply AD_Taylor, that seems to work like a charm.
 

Newfie

New Member
Joined
Jul 17, 2012
Messages
7
Hopefully one last thing, is it possible to move only the read emails to either the outlook archive, or a folder? with the code provided by Taylor?
 
Last edited:

AD_Taylor

Well-known Member
Joined
May 19, 2011
Messages
687
I've added a little bit to the code as requested. Now when the email is marked as read it is also moved to whichever folder is specified by 'myDestFolder'. Please see the comments on how to use it. Any questions let me know.

Hope this helps!

Code:
Sub SaveAttachments()
    Dim myOlapp         As Outlook.Application
    Dim myNameSpace     As Outlook.Namespace
    Dim myFolder        As Outlook.MAPIFolder
    Dim myItem          As Outlook.MailItem
    Dim myAttachment    As Outlook.Attachment
    Dim avDate()        As String
    Dim vDate           As String
    Dim i               As Long
    
    Dim PDFCount        As Long
    Dim myDestFolder    As Outlook.MAPIFolder
    
    Const myPath As String = "C:\test\"
    ReDim Preserve avDate(3)
    
    Set myOlapp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlapp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
    
    'Change 'Name Of Folder' below to the name of the folder you want the email (s) moved to
    'This folder must exist directly under the Inbox, i.e.
    'Inbox >
    '   Name Of Folder
    '   Test Folder >
    '       Test Folder 2 >
    '           Test Folder 3
    '
    ' 'Name of Folder' & 'Test Folder' are subfolders of the Inbox and 'Test Folder 2' is a subfolder of 'Test Folder'
    'With this code you can only get to 'Name of Folder' or 'Test Folder'
    'To get to 'Test Folder 2' requires an extra line of code
    Set myDestFolder = myFolder.Folders("Test Folder")
    
    'To get to subfolders build a series of code as below // Commented out so it doesn't run
    'Set myDestFolder = myDestFolder.Folders("Test Folder 2")
    'Set myDestFolder = myDestFolder.Folders("Test Folder 3")

    For Each myItem In myFolder.Items
        PDFCount = 0
        
        If myItem.UnRead = True Then
            avDate = Split(CStr(myItem.ReceivedTime), "/")
            vDate = Mid(avDate(2), 1, 4) & "-" & avDate(1) & "-" & avDate(0)
            
            If myItem.Attachments.Count <> 0 Then
                For Each myAttachment In myItem.Attachments
                    If UCase(Right(myAttachment.Filename, 3)) = "PDF" Then
                        i = i + 1
                        PDFCount = PDFCount + 1
                        myAttachment.SaveAsFile (myPath & vDate & " - " & i & " - " & _
                        myAttachment.Filename)
                    End If
                Next myAttachment
                
                If PDFCount > 0 Then
                    myItem.UnRead = False
                    myItem.Move myDestFolder
                End If
            End If
        End If
    Next myItem
End Sub
 

Newfie

New Member
Joined
Jul 17, 2012
Messages
7
Thanks again Taylor. This works to an extent, however it does not save and move all emails with PDF’s attached. For example, let’s say I have 100 emails with PDF attachments; I ran the code and it saved 40 of the attachments into my c:\test\, and moved the 40 emails to the test folder, and didn’t touch the other 60. So then I ran it again, this time it saved 35 of the attachments into c:\test\, moved the 35 emails to the test folder, and didn’t touch the remainder until I ran it for the 3rd time.

Any ideas what may be cause it not to process all emails in a single run?

Once again that’s for all of your help, and sorry for being a pain...
 

AD_Taylor

Well-known Member
Joined
May 19, 2011
Messages
687
No problem at all. I do find it strange as I'd expect it to just go through all of the emails...

Did the code run for all emails before I added the move folder bit?
 

Newfie

New Member
Joined
Jul 17, 2012
Messages
7
Yes, before the move to folder code was added all PDF's were being saved and emails were marked as read.
 

AD_Taylor

Well-known Member
Joined
May 19, 2011
Messages
687
I was a little bit stumped until I read the post on Stack Overflow: http://stackoverflow.com/questions/10725068/can-not-loop-through-all-needed-items-in-outlook-mailbox-using-vba
Basically when we move an item from the Inbox, it no longer exists. Because of this the myFolder.Items variable is modified to not include that item.
As an example imagine you are counting to 100 and when you get to number 50 suddenly it doesn't exist anymore. Because of this the number you are counting to gets modified to 99. This obviously means you are going to now ignore the 100th number and it will never get counted.

Hopefully that makes sense and the code below should fix it. We go backwards through the list from 100 to 1 instead which means we will always check every item. Also when testing it I was getting some Debug errors due to MeetingItems being in my Inbox so I've also added some code to make it only look at actual MailItems.

Hope this helps!

Code:
Sub SaveAttachments()
    Dim myOlapp         As Outlook.Application
    Dim myNameSpace     As Outlook.Namespace
    Dim myFolder        As Outlook.MAPIFolder
    Dim myItem          As Outlook.MailItem
    Dim myAttachment    As Outlook.Attachment
    Dim avDate()        As String
    Dim vDate           As String
    Dim i               As Long
    Dim j               As Long
    
    Dim PDFCount        As Long
    Dim myDestFolder    As Outlook.MAPIFolder
    
    Const myPath As String = "C:\test\"
    ReDim Preserve avDate(3)
    
    Set myOlapp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlapp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
    
    'Change 'Name Of Folder' below to the name of the folder you want the email (s) moved to
    'This folder must exist directly under the Inbox, i.e.
    'Inbox >
    '   Name Of Folder
    '   Test Folder >
    '       Test Folder 2 >
    '           Test Folder 3
    '
    ' 'Name of Folder' & 'Test Folder' are subfolders of the Inbox and 'Test Folder 2' is a subfolder of 'Test Folder'
    'With this code you can only get to 'Name of Folder' or 'Test Folder'
    'To get to 'Test Folder 2' requires an extra line of code
    Set myDestFolder = myFolder.Folders("Test Folder")
    
    'To get to subfolders build a series of code as below // Commented out so it doesn't run
    'Set myDestFolder = myDestFolder.Folders("Test Folder 2")
    'Set myDestFolder = myDestFolder.Folders("Test Folder 3")

    For i = myFolder.Items.Count To 1 Step -1
        If TypeName(myFolder.Items(i)) = "MailItem" Then
            Set myItem = myFolder.Items(i)
        End If
        PDFCount = 0
        
        If myItem.UnRead = True Then
            avDate = Split(CStr(myItem.ReceivedTime), "/")
            vDate = Mid(avDate(2), 1, 4) & "-" & avDate(1) & "-" & avDate(0)
            
            If myItem.Attachments.Count <> 0 Then
                For Each myAttachment In myItem.Attachments
                    If UCase(Right(myAttachment.Filename, 3)) = "PDF" Then
                        j = j + 1
                        PDFCount = PDFCount + 1
                        myAttachment.SaveAsFile (myPath & vDate & " - " & j & " - " & _
                        myAttachment.Filename)
                    End If
                Next myAttachment
                
                If PDFCount > 0 Then
                    myItem.UnRead = False
                    myItem.Move myDestFolder
                End If
            End If
        End If
    Next i
End Sub
 

Newfie

New Member
Joined
Jul 17, 2012
Messages
7
Thanks Taylor, sorry I have not had a chance to test this yet. I'll let you know how it goes in a couple of days.
 

Forum statistics

Threads
1,081,983
Messages
5,362,548
Members
400,679
Latest member
alecalec202

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top