[VBA] Save attachments uit embedded mail

[P_Tingen]

Situatie
Voor de orderverwerking lezen we de mail die binnenkomt in Outlook. De mail wordt via regels naar een order-map gestuurd, waarna een VBA macro er voor zorgt dat de bijlagen worden opgeslagen in een map op schijf. Onze eigen software pakt vanaf daar dan de orders weer op. Dit gaat niet goed wanneer klanten een mail-in-een-mail sturen, dus een embedded mail:



Wat er dan op schijf komt te staan is een .msg file in plaats van een .pdf of .xlsx bestand wat normaal gesproken gebeurt. Ik wil graag de .msg file bekijken en de bijlagen dáár weer uit opslaan.

Relevante software en hardware die ik gebruik
Outlook 365

Wat ik al gevonden of geprobeerd heb
Zie hieronder voor een versimpelde versie van mijn macro. Als je dit zelf wil proberen, pas dan op regel 7 de naam van de folder aan in Outlook waarvan je de bijlagen wilt bewaren en op regel 28 evt de map waar het naar toe moet (nu respectievelijk "orders" en "c:\temp\mail")

Dit werkt voor bijlagen, maar het gaat fout op regel 25-27. Hier dacht ik slim een recursieve aanroep te doen naar SaveToDisk, maar mijn objAtt is niet van type olMailItem maar altijd olAttachment en de check gaag dan ook mis. Bij een testmail had ik de check even uitgeschakeld, maar ook al zou de IF goed gaan, dan nog gaat het fout omdat SaveToDisk een MailItem verwacht als input en geen Attachment

code:

Sub SaveAttachments()
    Dim ns As Outlook.NameSpace
    Dim myItem As Object
    Dim i As Integer
    
    Set ns = Application.GetNamespace("MAPI")
    Set FolderItems = ns.GetDefaultFolder(olFolderInbox).Folders("Orders").Items
    
    For i = 1 To FolderItems.Count
        Set myItem = FolderItems(i)
        SaveToDisk myItem
    Next
End Sub


Sub SaveToDisk(objMsg As MailItem)
    Dim i As Integer
    Dim objAtt As Attachment
    Dim cFile As String
    
    If objMsg.Attachments.Count > 0 Then
        For i = 1 To objMsg.Attachments.Count
            Set objAtt = objMsg.Attachments(i)
            
            If objAtt.Class = olMailItem Then
              SaveToDisk objMsg
            Else
              cFile = "c:\temp\mail\mail-" & Format(objMsg.ReceivedTime, "hhmmss") & "-" & Replace(objAtt.FileName, " ", "_")
              objAtt.SaveAsFile cFile
            End If
        Next
    End If
End Sub

Suggesties zijn welkom ...

[Patrock]

Dus ALLE bijlagen worden nu mooi automatisch opgeslagen, en aangeroepen?...

Ik kan helaas geen on-topic reactie leveren, maar misschien is verdere validatie of een andere manier voor het verzamelen van de orders iets waar ook over nagedacht kan worden. Ook omdat spamfilters soms erg hardnekkig kunnen zijn op orderformulieren in excel/pdf als bijlage. Die van Office 365 kunnen behoorlijk veel blokkeren namelijk.

[P_Tingen]

Patrock schreef op woensdag 1 juli 2020 @ 13:40:
Dus ALLE bijlagen worden nu mooi automatisch opgeslagen, en aangeroepen?...

Ik kan helaas geen on-topic reactie leveren, maar misschien is verdere validatie of een andere manier voor het verzamelen van de orders iets waar ook over nagedacht kan worden. Ook omdat spamfilters soms erg hardnekkig kunnen zijn op orderformulieren in excel/pdf als bijlage. Die van Office 365 kunnen behoorlijk veel blokkeren namelijk.

Ja, op zich werkt dit systeem al een paar jaar goed. Spamfilters hebben we niet zoveel last van gelukkig. Aan de achterkant worden de bijlagen opgepakt en geanalyseerd door onze eigen software. Bijlagen die niet herkend worden, worden apart gezet. Alleen mail-in-mail gaat dus nog niet goed

[RedFox]

Geen ervaring met Outlook macro's, maar wat ik online tegenkom is dat je een embedded mail eerst moet downloaden en daarna openen. Dan kan je pas bij de attachments. Je zal dus moeten checken wat voor type attachments je hoofd mail heeft en op basis daarvan ze verwerken.

[P_Tingen]

Het item wat ik meegeef aan SaveToDisk is van het type 'attachment'. Ik zou hem eigenlijk moeten casten naar het type 'mailItem', maar hoe?

[farlane]

Als je de attachment als .msg hebt opgeslagen zou je em kunnen openen en dan de attachments opslaan. Voeg naar smaak recursie toe.

[P_Tingen]

Probleem is: hoe doe ik dat in VBA?

[eheijnen]

Jouw probleemstelling (er is een mail item als attachment bijgesloten) heb je al geformuleerd in de door jouw aangeleverde tekst.
Een beetje leesvoer over recursie (een routine die zichzelf aanroept - onder bepaalde condities -)
https://docs.microsoft.co...ting-recursive-procedures

Deze uitleg is in C maar de logica blijft gelijk in een andere programmeertaal.
https://www.cs.cmu.edu/~a...ecursions/recursions.html

[Kalentum]

P_Tingen schreef op donderdag 2 juli 2020 @ 08:44:
Probleem is: hoe doe ik dat in VBA?

Google eens op "VBA read msg file" en dat soort termen.

[P_Tingen]

Kalentum schreef op donderdag 2 juli 2020 @ 09:11:
[...]
Google eens op "VBA read msg file" en dat soort termen.

Op stackexchange een oplossing gevonden en uiteindelijk is het best mooi geworden:

code:

Global ns As Outlook.NameSpace
Global oInBox As Outlook.Folder
Global oTodo As Outlook.Folder
Global oDone As Outlook.Folder
Dim cSave As String

Sub VerwerkOrders()
    Dim oMsg As Object
    Dim i As Integer
    
    Set ns = Application.GetNamespace("MAPI")
    Set oInBox = ns.GetDefaultFolder(olFolderInbox)
    Set oTodo = oInBox.Folders("Orders")
    Set oDone = oInBox.Folders("Archief orders")
    cSave = "c:\temp\mail\"
    
    For i = oTodo.Items.Count To 1 Step -1
        Set oMsg = oTodo.Items(i)
        SaveAttachments oMsg
        oMsg.Move oDone
    Next
End Sub

Sub SaveAttachments(oMsg As MailItem)
    Dim oAtt As Outlook.Attachment
    Dim oItem As Object
    Dim i As Integer
    Dim cFile As String
    Dim cExt As String
        
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    For i = 1 To oMsg.Attachments.Count
        Set oAtt = oMsg.Attachments(i)
        
        cExt = LCase(Mid(oAtt.Filename, InStrRev("." & oAtt.Filename, ".")))
        
        If InStr("csv pdf xls xlsx msg", cExt) > 0 Then
            cFile = cSave & Format(oMsg.ReceivedTime, "hhmmss") & "-" & oAtt.Filename
            oAtt.SaveAsFile cFile
        End If 'check extentie
                          
        If cExt = "msg" Then
            Set oItem = ns.OpenSharedItem(cFile)
            SaveAttachments oItem
            oItem.Move oDone
            fso.deletefile cFile
        End If 'msg file
    Next
End Sub

Regel 15 gaat nog veranderd worden. In plaats van c:\temp wordt dat een netwerk-share waar ons orderprogramma de bijlagen oppakt.

[Voor 81% gewijzigd door P_Tingen op 02-07-2020 13:05]