Marcello ha adattato il mio script con una serie di modifiche secondo sue esigenze, mi ha autorizzato a pubblicare la sua versione che integrerò in un prossimo articolo aggiornato su Gioxx's Wall (vedi: https://gioxx.org/2018/01/16/savemodule-bas-0-3-per-outlook-2016-estrazione-pdf-dagli-allegati/)

SavePDF_Button-Marcello.bas

Public Sub Estrai_PDF()
	Dim ButtonName As String
	ButtonName = "Estrai PDF"
	Call ExportAttachments(ButtonName)
End Sub

Public Sub Estrai_Chiusure_PDF()
	Dim ButtonName As String
	ButtonName = "Estrai Chiusure PDF"
	Call ExportAttachments(ButtonName)
End Sub

Public Sub Estrai_Fatture_PDF()
	Dim ButtonName As String
	ButtonName = "Estrai Fatture PDF"
	Call ExportAttachments(ButtonName)
End Sub

Public Sub ExportAttachments(ButtonName As String)
	Dim objOL As Outlook.Application
	Dim objMsg As Outlook.MailItem 'Object
	Dim objAttachments As Outlook.Attachments
	Dim objSelection As Outlook.Selection
	Dim i As Long
	Dim lngCount As Long
	Dim strFile As String
	Dim strFolderpath As String
	Dim strDeletedFiles As String
	Dim dtDate As Date
	Dim sName As String
	Dim nomeFolder As String

	' Get the path to your Desktop folder
	strFolderpath = CreateObject("WScript.Shell").SpecialFolders(10)
	On Error Resume Next

	' Instantiate an Outlook Application object.
	Set objOL = CreateObject("Outlook.Application")

	' Get the collection of selected objects.
	Set objSelection = objOL.ActiveExplorer.Selection
	nomeFolder = IIf(ButtonName = "Estrai PDF", "", "\Archiviazione file\")

	' Set the Attachment folder.
	strFolderpath = strFolderpath & nomeFolder

	' Create directory Attachments if not exist
	If Dir(strFolderpath, vbDirectory) = "" Then
		MkDir strFolderpath
	End If

	' Set the Attachment folder.
	Select Case ButtonName
		Case "Estrai PDF"
		nomeFolder = "\Attachments\"
		Case "Estrai Chiusure PDF"
		nomeFolder = "\Chiusure\"
		Case "Estrai Fatture PDF"
		nomeFolder = "\Fatture\"
	End Select

	strFolderpath = strFolderpath & nomeFolder
	If Dir(strFolderpath, vbDirectory) = "" Then
		MkDir strFolderpath
	End If

	' Check each selected item for attachments.
	For Each objMsg In objSelection
		Set objAttachments = objMsg.Attachments
		lngCount = objAttachments.Count

		If lngCount > 0 Then
			dtDate = objMsg.SentOn
			'dtDate = objMsg.ReceivedDate
			sName = Format(dtDate, "ddmmyyyy", vbUseSystemDayOfWeek, vbUseSystem) & "_" & Format(dtDate, "hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "-"

			' Use a count down loop for removing items
			' from a collection. Otherwise, the loop counter gets
			' confused and only every other item is removed.

			For i = lngCount To 1 Step -1
				' Get the file name.
				'strFile = objAttachments.Item(i).FileName
				strFile = sName & objAttachments.Item(i).FileName
				sFileType = LCase$(Right$(strFile, 4))
				' Save the file only if is a PDF
				Select Case sFileType
					Case ".PDF", ".pdf"
					' Combine with the path to the Temp folder.
					strFile = strFolderpath & strFile
					' Save the attachment as a file.
					objAttachments.Item(i).SaveAsFile strFile
				End Select
			Next i
		End If
		
	Next

	ExitSub:

	Set objAttachments = Nothing
	Set objMsg = Nothing
	Set objSelection = Nothing
	Set objOL = Nothing
End Sub