|
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 |
