Salvare automaticamente in una cartella specifica tutti i file pdf che ricevo via e-mail

Question

Buona sera a tutti, ricevo quotidianamente sul mio account di posta elettronica ( uso Outlook) un numero elevato di file pdf giornalieri.

Sono costretto ad aprirli uno per volta e salvarli in una cartella specifica.

Vi chiedo se sia possibile automatizzare questa procedura con una routine che al semplice clic sul file pdf allegato venga salvato nella cartella specificata.

Oppure se mi potete indicare altre soluzioni possibili per fare questo.

Ciao Nicola.

Answer 1

Ciao Nicola,

Oltre all'ottimo suggerimento di Laura, potresti trovare, sempre in inglese, una discussione, più approfondita del codice originale di Ron de Bruin alla seguente pagina:

              **http://www.rondebruin.nl/win/s1/outlook/saveatt.htm**

===

Regards,

Norman

Answer 2

Ciao Nicola,

La funziona da te richiesta non è presente di default su Outlook 2010.

Se hai dimestichezza con l'inglese e con le impostazioni del PC, puoi però fare riferimento a questo articolo. Si tratta di una discussione sul Forum di MSDN dove altri Utenti hanno necessità di effettuare la tua stessa operazione.

Fammi sapere.

Saluti,

Laura

Answer 3

Ciao Nicola,

ho adattato il codice sottoriportato alle mie esigenze, si verifica l'errore alle righe in grassetto cosa non va?.

Ho fatto tutto questo prima di provare il codice sottostante.

1. ho attivato la libreria Microsoft Outlook 15.0 Object Library;
2. ho creato una cartella chiamata prova in C;
3. ho cambiato in pdf il tipo di File nel codice.

Sub Test()

'This will copy all pdf files from “MyFolder” to "C:\Users\Ron\test"

    SaveEmailAttachmentsToFolder "MyFolder", "pdf", "C:\prova"

[cut]

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _

ExtString As String, DestFolder As String)

    Dim ns As Namespace

    Dim Inbox As MAPIFolder

    Dim SubFolder As MAPIFolder

[cut]  

        For Each Atmt In Item.Attachments

            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then

                FileName = DestFolder & Item.SenderName & " " & Atmt.FileName

                Atmt**.SaveAsFile FileName**

[Cut]

A me il codice funziona senza problemi. Sostituendo il nome Nicola per il tuo Folder Prova, ottengo:

Quindi, facci sapere, per favore, il numero e il testo dell'errore che riscontri. Inoltre, prova  ad inserire l'istruzione in grassetto e posta il risultato ottenuto nella finestra Immediate:

                FileName = DestFolder & Item.SenderName & " " & Atmt.FileName

Debug.Print FileName

                Atmt.SaveAsFile FileName

===

Regards,

Norman

Answer 4

Buongiorno a tutti, Ciao Laura, ciao Norman ho adattato il codice sottoriportato alle mie esigenze, si verifica l'errore alle righe in grassetto cosa non va?.

Ho fatto tutto questo prima di provare il codice sottostante.

1. ho attivato la libreria Microsoft Outlook 15.0 Object Library;
2. ho creato una cartella chiamata prova in C;
3. ho cambiato in pdf il tipo di File nel codice.

Sub Test()

'This will copy all pdf files from “MyFolder” to "C:\Users\Ron\test"

    SaveEmailAttachmentsToFolder "MyFolder", "pdf", "C:\prova"

End Sub

'Note: You not have to change the code in the macro below. But you can change Item.SenderName to ReceivedTime in the save line like Format(Item.ReceivedTime, "yyyy-mmm-dd")

'When you do that it will put the ReceivedTime before each file name instead of the SenderName

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _

ExtString As String, DestFolder As String)

    Dim ns As Namespace

    Dim Inbox As MAPIFolder

    Dim SubFolder As MAPIFolder

    Dim Item As Object

    Dim Atmt As Attachment

    Dim FileName As String

    Dim MyDocPath As String

    Dim I As Integer

    Dim wsh As Object

    Dim fs As Object

    On Error GoTo ThisMacro_err

    Set ns = GetNamespace("MAPI")

    Set Inbox = ns.GetDefaultFolder(olFolderInbox)

    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

    I = 0

    ' Check subfolder for messages and exit of none found

    If SubFolder.Items.Count = 0 Then

        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _

               vbInformation, "Nothing Found"

        Set SubFolder = Nothing

        Set Inbox = Nothing

        Set ns = Nothing

        Exit Sub

    End If

    'Create DestFolder if DestFolder = ""

    If DestFolder = "" Then

        Set wsh = CreateObject("WScript.Shell")

        Set fs = CreateObject("Scripting.FileSystemObject")

        MyDocPath = wsh.SpecialFolders.Item("mydocuments")

        DestFolder = MyDocPath & "" & Format(Now, "dd-mmm-yyyy hh-mm-ss")

        If Not fs.FolderExists(DestFolder) Then

            fs.CreateFolder DestFolder

        End If

    End If

    If Right(DestFolder, 1) <> "" Then

        DestFolder = DestFolder & ""

    End If

    ' Check each message for attachments and extensions

    For Each Item In SubFolder.Items

        For Each Atmt In Item.Attachments

            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then

                FileName = DestFolder & Item.SenderName & " " & Atmt.FileName

                Atmt**.SaveAsFile FileName**

                I = I + 1

            End If

        Next Atmt

    Next Item

    ' Show this message when Finished

    If I > 0 Then

        MsgBox "You can find the files here : " _

             & DestFolder, vbInformation, "Finished!"

    Else

        MsgBox "No attached files in your mail.", vbInformation, "Finished!"

    End If

    ' Clear memory

ThisMacro_exit:

    Set SubFolder = Nothing

    Set Inbox = Nothing

    Set ns = Nothing

    Set fs = Nothing

    Set wsh = Nothing

    Exit Sub

    ' Error information

ThisMacro_err:

    MsgBox "An unexpected error has occurred." _

         & vbCrLf & "Please note and report the following information." _

         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _

         & vbCrLf & "Error Number: " & Err.Number _

         & vbCrLf & "Error Description: " & Err.Description _

         , vbCritical, "Error!"

    Resume ThisMacro_exit

End Sub

Ciao Nicola.

Answer 5

Grazie Laura, grazie Norman innanzitutto grazie per il vostro cortese riscontro. Seguo i vostri consigli e vi aggiorno. Ciao Nicola.