Option Explicit
Public Sub unzipFiles()
If InStr(1, Application.ActiveExplorer.Caption, "Entwürfe") = 0 Then
MsgBox "Dieses Makro ist lediglich für den ""Entwürfe""-Ordner vorgesehen.", vbInformation
Exit Sub
End If
Dim o As Object
Dim mail As MailItem
Dim fso As Object
Dim fldTmp As Object
Dim f As Object
Dim attach As Attachment
Dim shell As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(Environ("Temp") & "\unzip") Then
fso.DeleteFolder Environ("Temp") & "\unzip"
End If
Set fldTmp = fso.CreateFolder(Environ("Temp") & "\unzip")
Set shell = CreateObject("Shell.Application")
For Each o In Application.ActiveExplorer.Selection
If TypeName(o) = "MailItem" Then
Set mail = o
For Each attach In mail.Attachments
attach.SaveAsFile fldTmp.Path & "\" & attach.FileName
attach.Delete
Next attach
For Each f In fldTmp.Files
If fso.GetExtensionName(f.Path) = "zip" Then
shell.NameSpace(fldTmp.Path).copyhere shell.NameSpace(f.Path).Items
End If
Next f
For Each f In fldTmp.Files
If Not fso.GetExtensionName(f.Path) = "zip" Then
mail.Attachments.Add f.Path
End If
f.Delete
Next f
mail.Save
End If
Next o
Set shell = Nothing
Set fldTmp = Nothing
Set mail = Nothing
Set fso = Nothing
End Sub