VBA per salvare un allegato mail da outlook in automatico

[creminabagnata]

Buongiorno a tutti,
Sono curioso di sapere se è possibile far salvare a outlook tutti gli allegati delle mail che arrivano in una determinata cartella specificata.
Mi pare di capire che è necessario uno script vba. dove lo posso trovare? Come lo uso?

Vi ringrazio molto!

[tas]

Qui sei OT, ti sposto.

[SigmaBeta]

Ciao.
Prova questo codice, lo uso comunemente con MSAccess.
Spero che in tanti mesi ti abbiano però già risposto.
Ovviamente se scarichi tutti gli allegati non farai come nell'esempio la selezione per estenzione.
Per non scaricare lo stesso puoi invece mettere una selezione sulle date.
Ecco il codice:

Function GetAttachments()
On Error GoTo GetAttachments_err

    Dim strExtension1 As String
    Dim strExtension2 As String
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim Item As Outlook.MailItem
    Dim Atmt As Outlook.Attachment
    Dim filename As String
    Dim intI As Integer
    Dim Outlook As Object
    Dim strPath As String
    Dim rs As Recordset
    Dim strAttachment As String
    Dim strSentOn As String
    
    Set Outlook = CreateObject("Outlook.Application")
    strExtension1 = "*.xls"
    strExtension2 = "*.doc"
    strPath = Left(Forms!frmDefault!cmbDatabase.Column(1), (InStrRev(Forms!frmDefault!cmbDatabase.Column(1), "\")))
    If Dir(strPath & "\PodSource", vbDirectory) = "" Then MkDir (strPath & "\PodSource")
    
    Set ns = Outlook.GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
 
    If Inbox.Items.Count = 0 Then
        MsgBox "There are no messages in the Inbox.", vbInformation + vbOKOnly, "P&G - POD TOOL"
        Exit Function
    End If
    
   Set rs = db.OpenRecordset("Attachment")
   
   For Each Item In Inbox.Items
        If Item.SentOn > Forms!frmDefault!txtInitialDate And Item.Attachments.Count > 0 Then
        For Each Atmt In Item.Attachments
             If Left(Atmt.filename, 3) = "POD" And ((Right(Atmt.filename, 4) = strExtension1 Or Right(Atmt.filename, 4) = strExtension2)) Then
                strAttachment = Atmt.filename
                strSentOn = Item.SentOn
                If basGeneral.AtmtIsNew(strAttachment) = True Then
                    filename = strPath & "\PODArrivals\" & Atmt.filename
                    Atmt.SaveAsFile filename
                    rs.AddNew
                    rs!Attachment = strAttachment
                    rs!SentOn = strSentOn
                    rs.Update
                    intI = intI + 1
                End If
            End If
        Next Atmt
        End If
    Next
    rs.Close
    
    If intI > 0 Then
        MsgBox "I found " & intI & " attached files.", vbInformation + vbOKOnly, "Finished!"
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation + vbOKOnly, "Finished!"
    End If
    
GetAttachments_exit:
       Set Atmt = Nothing
       Set Item = Nothing
       Set ns = Nothing
       Exit Function

GetAttachments_err:
       If Err.Number = 13 Then Resume
       MsgBox "An unexpected error has occurred." _
          & vbCrLf & "Please note and report the following information." _
          & vbCrLf & "Macro Name: GetAttachments" _
          & vbCrLf & "Error Number: " & Err.Number _
          & vbCrLf & "Error Description: " & Err.Description _
          , vbCritical, "Error!"
       Resume GetAttachments_exit

End Function
Function TableExist(ByVal strTableName As String) As Boolean

    Dim tdfCycle As TableDef
    TableExist = False

    With db
        
        ' Call all the Tables
        For Each tdfCycle In .TableDefs
            'Debug.Print "    " & tdfCiclo.Name
            If tdfCycle.Name = strTableName Then
                TableExist = True
                Exit Function
            End If
        Next tdfCycle

    End With

End Function