La funzione permette di scaricare automaticamente uno o più file PDF allegati a una mail in ingresso in Outlook 2016. Consulta il blog per maggiori informazioni: https://wp.me/pdQ5q-8LY

SavePDF_Rule.bas

Attribute VB_Name = "SavePDFRule"
'  Outlook 2016: Save all PDF Attachments
'  -----------------------------------------------------------------------------------------------------------
'  Author:          GSolone
'  Version:         0.3
'  Based on:        "Run a Script Rule to Save Attachments"
'                   (https://www.slipstick.com/developer/save-attachments-to-the-hard-drive/)
'  Last modified:   15-01-2020
'  Credits:         http://www.visual-basic-tutorials.com/Tutorials/MsCodes/get-special-directories-path-in-visual-basic.htm
'                   http://www.vbaexpress.com/forum/showthread.php?7866-Check-for-folder-create-if-it-does-not-exist
'                   http://www.pixelchef.net/content/rule-autosave-attachment-outlook?page=2
'                   https://www.slipstick.com/outlook/rules/outlook-2016-run-a-script-rules/
'  ------------------------------------------------------------------------------------------------------------
'  UPDATES:
'   0.3- Fixed Item.ReceivedTime and dtDateRule problem (Runtime error 91 or 424)
'   0.2- I prepend SentOn (Date) to attachments, to solve the problem of the attachments with the same file name.

Public Sub SaveAttachments(Item As Outlook.MailItem)

If Item.Attachments.Count > 0 Then
 
    Dim objOL As Outlook.Application
    Dim objAttachments As Outlook.Attachments
    Dim lngCount As Long
    Dim strFile As String
    Dim sFileType As String
    Dim i As Long
    Dim dtDateRule As Date
    Dim sNameRule As String
    
    Set objAttachments = Item.Attachments
    lngCount = objAttachments.Count
    For i = lngCount To 1 Step -1
        dtDateRule = Item.ReceivedTime
        sNameRule = Format(dtDateRule, "ddmmyyyy", vbUseSystemDayOfWeek, vbUseSystem) & "_" & Format(dtDateRule, "hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "-"
        ' Get the file name.
        strFile = sNameRule & objAttachments.Item(i).FileName
        ' Get the path to your Desktop folder
        strFolderpath = CreateObject("WScript.Shell").SpecialFolders(10)
        strFolderpath = strFolderpath & "\Attachments\"
        ' Create directory Attachments if not exist
        If Dir(strFolderpath, vbDirectory) = "" Then
            MkDir strFolderpath
        End If
        ' Save the file only if is a PDF
        If InStr(strFile, ".pdf") Then
            ' Combine with the path to the folder.
            strFile = strFolderpath & strFile
            ' Save the attachment as a file.
            objAttachments.Item(i).SaveAsFile strFile
        End If
    Next i

End If
End Sub