Foto's als bijlage direct opslaan in map

Sub BijlagenOpslaan()
On Error GoTo BijlagenOpslaan_err

Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String, Pad As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
    
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = ns.PickFolder
    i = 0

    ' Controleer de gekozen folder en stop als er geen mails in zitten.
    If SubFolder.Items.Count = 0 Then
        MsgBox "Er zijn geen mailtjes in de map " & SubFolder.Name & ".", vbInformation, "Niks gevonden..."
        Exit Sub
    End If

    ' Controleer of de mails een bijlage bevatten.
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            ' Controleer de extensie van de bijlagen.
            If Right(Atmt.FileName, 3) = "jpg" Or Right(Atmt.FileName, 3) = "png" Then
            ' Pad wordt aangemaakt als het niet bestaat; gebaseerd op datum/tijd.
                On Error GoTo DirMaken
                Pad = "H:\Camera\" & Format(Item.CreationTime, "yyyymmdd") & "\"
                If Dir(Pad, vbDirectory) & "" = "" Then MaakFolder (Pad)
                FileName = Pad & Atmt.FileName
                Atmt.SaveAsFile FileName
                i = i + 1
            End If
        Next Atmt
    Next Item

    ' Samenvatting laten zien.
    If i > 0 Then
        varResponse = MsgBox("Er zijn " & i & " foto's gevonden." & vbCrLf _
        & "Deze zijn opgeslagen in de map H:\Camera\." & vbCrLf & vbCrLf _
        & "Wil je ze nu bekijken?", vbQuestion + vbYesNo, "KLaar!")

        ' Windows Explorer openen en de bestanden laten zien
        If varResponse = vbYes Then
            Shell "Explorer.exe /e, " & Pad & ", vbNormalFocus"
        End If
    Else
        MsgBox "Geen bijlagen gevonden in de mails.", vbInformation, "Klaar!"
    End If

'-----------------------------------------------------------------------------------------
' Alles opschonen
'-----------------------------------------------------------------------------------------
BijlagenOpslaan_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub

'-----------------------------------------------------------------------------------------
' Foutafhandeling
'-----------------------------------------------------------------------------------------
BijlagenOpslaan_err:
    MsgBox "Er is een onverwachte fout opgetreden." & vbCrLf _
        & "Noteer en meld de volgende foutmelding:" & vbCrLf _
        & "Macro Naam: BijlagenOpslaan" & vbCrLf _
        & "Fout nummer: " & Err.Number & vbCrLf _
        & "Omschrijving: " & Err.Description, vbCritical, "Error!"
    Resume BijlagenOpslaan_exit

DirMaken:
'-----------------------------------------------------------------------------------------
'Nieuwe map maken als hij nog niet bestaat
'-----------------------------------------------------------------------------------------
    Call MaakFolder(Pad)
    Resume Next

End Sub

Function MaakFolder(strFolder)
'Aanroepen met:     MaakFolder "D:\Apps\Sjablonen\Oost\Sjablonen\"
Dim oFSO As Object
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    If oFSO.FolderExists(strFolder) Then
        Exit Function
    Else
        MaakFolder (oFSO.GetParentFolderName(strFolder))
    End If
    oFSO.CreateFolder (strFolder)
    Set oFSO = Nothing
End Function