Outlook Macro Save Only PDF Attachments and mark Email as read

[Newfie]

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]

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.

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]

Thanks for the quick reply AD_Taylor, that seems to work like a charm.

 

[Newfie]

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?

 

[AD_Taylor]

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!

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]

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 3^rd 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]

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]

Yes, before the move to folder code was added all PDF's were being saved and emails were marked as read.

 

[AD_Taylor]

I was a little bit stumped until I read the post on Stack Overflow: http://stackoverflow.com/questions/...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!

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]

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.