Van alle mails de bijlagen opslaan en de mail als bestand naar een servermap

ADvH · 20 mrt 2019

Beste allemaal,
In outlook heb ik een map waarin alle digitale facturen per mail binnenkomen. In iedere mail zit een PDF en een XML bestand. Deze 2 bijlage worden opgeslagen in een map op de server waarna de mail als msg bestand wordt gearchiveerd eveneens ook in een map op de server en de mail uit deze outlook facturenmap wordt verwijderd. Ik heb het in VBA voor elkaar dat dit werkt, echter ik krijg het niet voor elkaar dat dat voor álle mails in de outlookmap 'facturen' gebeurd.
(De map facturen in outlook 'hangt' direct onder Postvak IN)

Dit is de code die ik tot nu toe heb:

Code:

Sub VerwerkingFacturen()
' Deze macro slaat de bijlagen van de geselecteerde mail op en verplaatst de mail naar een andere emailmap

Dim item As Object
Dim mail As Outlook.MailItem
Dim Bijlage As Attachment
Dim attBestandsnaam As String
Dim attPath As String
Dim mBestandsnaam As String
Dim mPath As String

mPath = "H:\Documents\archief\"  'map voor opslag van de mail als msg bestand
attPath = "H:\Documents\facturen\"  'map voor opslag van de bijlagen
    
    For Each item In Application.Explorers.Explorers(1).Selection  '(hier zit denk ik de fout)
    'in eigen woorden zou hier moeten komen: voor elke mail in de outlookmap 'facturen' doe onderstaande
        If TypeName(item) <> "MailItem" Then
            MsgBox "Selecteer eerst een mailbericht...", vbInformation, "Opdracht niet mogelijk"
            Exit Sub
        End If
            'sla de bijlagen uit de mail op
            For Each Bijlage In item.Attachments
                attBestandsnaam = attPath & Bijlage.FileName
                Bijlage.SaveAsFile attBestandsnaam
            Next Bijlage
                'verplaats de mail met bijlage naar een archiefmap
               
 Set mail = item
                
                    FileName = Replace(mail.Subject, ":", "")
                    FileName = Replace(FileName, "/", "")
                    FileName = Replace(FileName, "\", "")
                    FileName = Replace(FileName, "<", "")
                    FileName = Replace(FileName, ">", "")
                    FileName = Replace(FileName, ";", "")
                    FileName = Replace(FileName, "*", "")
                    FileName = Replace(FileName, ":", "")
                    FileName = Replace(FileName, "?", "")
                    FileName = Replace(FileName, "|", "")
                    FileName = Replace(FileName, ".", "")
        
                    mBestandsnaam = mPath & FileName
                    If mBestandsnaam = "Onwaar" Then Exit Sub

                    mail.SaveAs mBestandsnaam & ".msg", olMSG
                    'mail.Delete

    Next
    
End Sub

Hopelijk heeft iemand de oplossing,

Hartelijke groet Albert

ADvH · 21 mrt 2019

Lastige vraag blijkbaar

Heb het nu opgelost door eerst alle mail in de map te selecteren en vervolgens de actie uit te voeren:
Gelijk ook nog een controle ingebouwd om te checken of je in de juiste map staat

Code:

Sub VerwerkingFacturen()
' Deze macro slaat de bijlagen van de geselectewerde mail op en verplaatst de mail naar een andere emailmap

    Dim item As Object
    Dim mail As MailItem
    Dim Bijlage As Attachment
    Dim attBestandsnaam As String
    Dim attPath As String
    Dim map As String
    Dim mBestandsnaam As String
    Dim mPath As String

    mPath = "H:\Documents\algemeen\test\"
    attPath = "H:\Documents\algemeen\test\"

    map = Application.ActiveExplorer.CurrentFolder
    
    If map <> "xxxfacturenxxx" Then
        MsgBox "je staat niet in de map met xxxfacturenxxx", vbInformation, "opdracht niet mogelijk"
        Exit Sub
    End If
    
    Application.ActiveExplorer.SelectAllItems
    For Each item In Application.ActiveExplorer.Selection
    
        If TypeName(item) <> "MailItem" Then
            MsgBox "Selecteer eerst een mailbericht...", vbInformation, "Opdracht niet mogelijk"
            Exit Sub
        End If
            'sla de bijlagen uit de mail op
            For Each Bijlage In item.Attachments
                attBestandsnaam = attPath & Bijlage.FileName
                Bijlage.SaveAsFile attBestandsnaam
            Next Bijlage
                
                'verplaats de mail met bijlage naar een archiefmap
                Set mail = item
                    FileName = Replace(mail.Subject, ":", "")
                    FileName = Replace(FileName, "/", "")
                    FileName = Replace(FileName, "\", "")
                    FileName = Replace(FileName, "<", "")
                    FileName = Replace(FileName, ">", "")
                    FileName = Replace(FileName, ";", "")
                    FileName = Replace(FileName, "*", "")
                    FileName = Replace(FileName, ":", "")
                    FileName = Replace(FileName, "?", "")
                    FileName = Replace(FileName, "|", "")
                    FileName = Replace(FileName, ".", "")
        
                mBestandsnaam = mPath & FileName
                If mBestandsnaam = "Onwaar" Then Exit Sub

                mail.SaveAs mBestandsnaam & ".msg", olMSG
                mail.Delete

    Next
    
End Sub

Vriendelijke groet Albert

Van alle mails de bijlagen opslaan en de mail als bestand naar een servermap

ADvH

Gebruiker

ADvH

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy