Skip to content

Instantly share code, notes, and snippets.

@gioxx
Created June 12, 2020 08:59
Show Gist options
  • Save gioxx/85ae84c28464da70086bf6bbcf941327 to your computer and use it in GitHub Desktop.
Save gioxx/85ae84c28464da70086bf6bbcf941327 to your computer and use it in GitHub Desktop.
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/)
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment