Attribute VB_Name = "EsportaPowerpoint"
Public Sub SavePowerPointAttachments()
    Dim objOutlook As Outlook.Application
    Dim objNamespace As Outlook.NameSpace
    Dim objFolder As Outlook.Folder
    Dim strFolderPath As String
    
    ' Imposta l'istanza di Outlook e il namespace
    Set objOutlook = Outlook.Application
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    
    ' Imposta il percorso di destinazione per gli allegati salvati
    strFolderPath = "\\mediaset.it\share\Indirizzo_controllo_risorse\EMAIL_CA\PowerPoints\"
    
    ' Assicurati che la cartella di destinazione esista
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    If Not fs.FolderExists(strFolderPath) Then
        fs.CreateFolder (strFolderPath)
    End If
    
    ' Ottieni la cartella principale (es. "Personal Folders") e avvia la scansione ricorsiva
    Set objFolder = objNamespace.Folders.Item("Mauro.Gagliardi@Mediaset.it") ' Modifica se necessario per corrispondere al tuo profilo Outlook
    ProcessFolders objFolder, strFolderPath, fs
    
    MsgBox "Outlook: esportazione Powerpoint completata!", vbInformation
End Sub

Private Sub ProcessFolders(ByVal objFolder As Outlook.Folder, ByVal strFolderPath As String, ByVal fs As Object)
    Dim objSubFolder As Outlook.Folder
    Dim objItem As Object
    Dim objAttachment As Outlook.Attachment
    Dim formattedDate As String
    Dim strFileName As String
    Dim strFileExt As String
    Dim receivedYear As Integer
    
    ' Processa tutte le email nella cartella corrente
    For Each objItem In objFolder.Items
        If TypeName(objItem) = "MailItem" Then
            ' Ottieni l'anno di ricezione e verifica se è 2024
            receivedYear = Year(objItem.ReceivedTime)
            
            If receivedYear >= 2024 Then
                ' Controlla se il corpo dell'email non contiene il testo specifico
                If InStr(1, objItem.Body, "Stefano Corbetta", vbTextCompare) = 0 Then
                    ' Il testo non è presente, quindi procedi a verificare gli allegati
                    For Each objAttachment In objItem.Attachments
                        strFileName = objAttachment.fileName
                        strFileExt = LCase$(fs.GetExtensionName(strFileName))
                        
                        ' Verifica se l'allegato è un PowerPoint
                        If (strFileExt = "pptx" Or strFileExt = "ppt") Then
                            ' Anteponi la data di ricezione formattata al nome del file e salva l'allegato
                            formattedDate = Format(objItem.ReceivedTime, "yyyy-mm-dd")
                            strFileName = formattedDate & " " & strFileName
                            objAttachment.SaveAsFile strFolderPath & strFileName
                        End If
                    Next objAttachment
                End If
            End If
        End If
    Next objItem


    
    ' Processa ricorsivamente tutte le sottocartelle
    For Each objSubFolder In objFolder.Folders
        ProcessFolders objSubFolder, strFolderPath, fs
    Next objSubFolder
End Sub