Bijlages automatisch opslaan

[AatB]

Hallo,

Ik wil van bepaalde mails de bijlages opslaan.

Nu ben ik al een heel eind met de volgende code;

Sub CSV_Nota()

    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim ArchFolder As MAPIFolder
    
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FName, FType, MyDocPath, TmpFolder, ExportFolder, ReportFolder, sFolder, vFolder As String
    Dim wsh, fs As Object
    Dim I, M As Integer
    
    sFolder = "Import CSV Nota"
    vFolder = "Verwerkt"
        
    'Get the Inbox of Outlook
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    
    For I = 1 To Inbox.Folders.Count
        If Inbox.Folders.Item(I).Name = sFolder Then
            Set SubFolder = Inbox.Folders("Import CSV Nota")
            GoTo arch
        End If
    Next
    Set SubFolder = Inbox.Folders.Add(sFolder)
    
arch:
    For I = 1 To SubFolder.Folders.Count
        If SubFolder.Folders.Item(I).Name = vFolder Then
            Set ArchFolder = Inbox.Folders(sFolder).Folders(vFolder)
            GoTo start
        End If
    Next
    Set ArchFolder = Inbox.Folders(sFolder).Folders.Add(vFolder)
    
start:
    Set wsh = CreateObject("WScript.Shell")
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'Define the subfolder where you want to save the attachments
    TmpFolder = "\\fserver01\data$\Import CSV Nota"
    If Not fs.FolderExists(TmpFolder) Then
        fs.CreateFolder TmpFolder
    End If
    
    ExportFolder = TmpFolder
        
    For M = SubFolder.Items.Count To 1 Step -1
        I = 0
        For Each Atmt In SubFolder.Items(M).Attachments
            I = 0
            FType = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
            Select Case FType
                Case ".txt", ".csv"
                    FName = ExportFolder & "\" & Atmt.FileName
                    Atmt.SaveAsFile FName
                    I = 1
           End Select
        Next Atmt
        If I = 1 Then
            SubFolder.Items(M).UnRead = False
            SubFolder.Items(M).Move ArchFolder
        End If
    Next
        
    ' Clear memory
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    
End Sub

Het probleem is dat ik twee accounts heb en dus ook 2 inboxen.
De code set nu de default inbox van het default account.
Kunnen jullie mij vertellen wat ik moet doen om de default inbox te kunnen setten van het andere account?

'Get the Inbox of Outlook
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)

Ik hoor het graag.....

mvg,

Aat