Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Puoi scaricare uno o più file PDF allegati a una o più mail già presenti in Outlook 2016 (tramite pulsante della barra multifunzione) o scatenare lo script tramite regola, per esempio per permetterne il funzionamento all'arrivo di una nuova mail. Consulta il blog per maggiori informazioni: https://wp.me/pdQ5q-8LY
Attribute VB_Name = "SaveModule"
' Outlook 2016: Save all PDF Attachments
' -----------------------------------------------------------------------------------------------------------
' Author: GSolone
' Version: 0.1
' Based on: "Run a Script Rule to Save Attachments"
' (https://www.slipstick.com/developer/save-attachments-to-the-hard-drive/)
' Info: https://gioxx.org/tag/microsoft-outlook
' Last modified: 27-09-2017
' 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:
' -
Public Sub SaveAttachments(Item As Outlook.MailItem)
If Item.Attachments.Count > 0 Then
Dim objAttachments As Outlook.Attachments
Dim lngCount As Long
Dim strFile As String
Dim sFileType As String
Dim i As Long
Set objAttachments = Item.Attachments
lngCount = objAttachments.Count
For i = lngCount To 1 Step -1
' Get the file name.
strFile = 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
' Outlook 2016: Save all PDF Attachments (Macro Button)
' -----------------------------------------------------------------------------------------------------------
' Author: GSolone
' Version: 0.1
' Based on: "Save Attachments to the hard drive"
' (https://www.slipstick.com/developer/save-attachments-to-the-hard-drive/)
' Info: https://gioxx.org/tag/microsoft-outlook
' Last modified: 28-09-2017
' 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/
' ------------------------------------------------------------------------------------------------------------
' WARNING:
' You'll need to set macro security to warn before enabling macros or
' sign the macro. You can change the folder name or path where the attachments
' are saved by editing the code.
'
' UPDATES:
' -
Public Sub ExportAttachments()
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
' 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
' Set the Attachment folder.
strFolderpath = strFolderpath & "\Attachments\"
' Create directory Attachments if not exist
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
' 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
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment