Outlook Remove Attachments

Sub remove_attachments()

    Dim app As Outlook.Application
    Set app = CreateObject("Outlook.Application")

    Dim ns As Outlook.NameSpace
    Set ns = app.GetNamespace("MAPI")
    ns.Logon

    Dim pst As Outlook.MAPIFolder
    Set pst = ns.Folders("Outlook Archiv - Work Old")

    Dim root As Outlook.MAPIFolder
    Set root = pst.Folders("_old")

    Call remove_attachments_rec(root)
    Beep

End Sub

Sub remove_attachments_rec(root As Outlook.MAPIFolder)

    Dim subFolder As Outlook.MAPIFolder
    For Each subFolder In root.Folders
        Call remove_attachments_rec(subFolder)
    Next

    Dim item As Outlook.MailItem
    Dim atts As Outlook.Attachments
    Dim obj As Object
    For Each obj In root.Items
        If TypeName(obj) = "MailItem" Then
            Set item = obj
            Set atts = item.Attachments
            If atts.Count > 0 Then
                While atts.Count > 0
                    atts(1).Delete
                Wend
                item.Save
            End If
        End If
    Next

End Sub