You are going to need something a little more complex. The major problem for doing this automatically is the password. Is the password always going to be the same for each zip attachment?

How are you going to identify the messages that have the password as opposed to other messages with zip attachments that are not password protected, because if you send the wrong password Z-Zip will not extract the contents.

The following can be used to extract messages with zip attachments, whether they are password protected or not, but you are going to have to tell the process what the password is or enter it at the prompt. If there is no password set the password to a null string.

Make sure that the code correctly locates the Z-Zip folder. the location shown is from my PC. If the password is the same for all zips, hard code the password instead of using the input box.

If you are going to run the main code from a rule, you will have to ensure that the rule correctly identifiues the incoming messages.

I have included error trapping to ensure that no extracted folders are overwritten, and a test macro so that you can test the process with messages in your inbox.

I have also included alternative code that does not use Z-Zip (but it will not address password protected Zips either). This is for the benefit of others who may later access the thread.

Option Explicit

Sub TestUnzip()
'An Office macro by Graham Mayor - www.gmayor.com
Dim olMsg As MailItem
    'On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    UnzipAttachments olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub UnzipAttachments(Item As Outlook.MailItem)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim olAtt As Attachment
Dim strFileName As String
Dim strPath As String

strPath = Environ("Temp") & "\ZipTemp"       'Folder to save temporary files
    If Item.Attachments.Count > 0 Then
        For Each olAtt In Item.Attachments
            If Right(LCase(olAtt.FileName), 3) = "zip" Then
                CreateFolders strPath
                olAtt.SaveAsFile strPath & olAtt.FileName
                'UnZipFile strPath & olAtt.FileName
                UnzipWithPassword strPath & olAtt.FileName
                Kill strPath & olAtt.FileName
            End If
        Next olAtt
    End If
lbl_Exit:
    Set olAtt = Nothing
    Exit Sub
End Sub

Private Sub UnzipWithPassword(fname As Variant)
Dim FSO As Object
Dim oApp As Object
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Dim sPathTo7ZipExe As String
Dim sZipPassword As String
Const strFolder As String = "C:\Path\Unzipped"
    sPathTo7ZipExe = "C:\Program Files (x86)\7-Zip\7z.exe"
    sZipPassword = InputBox("Enter ZIP Password", "Unzip Files") '"asdfasdf"  ' zip password

    'Create the folder name
    strDate = Format(Now, " dd-mm-yy")
    FileNameFolder = FolderNameUnique(strFolder & strDate & "\")

    'Make the normal folder in DefPath
    CreateFolders CStr(FileNameFolder)

    Shell sPathTo7ZipExe & " x -y -p" & sZipPassword & " -o""" & _
          FileNameFolder & """ """ & fname, vbHide

    MsgBox "You find the files here: " & FileNameFolder
lbl_Exit:
    Exit Sub
End Sub

Private Sub UnZipFile(fname As Variant)
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
Dim oShell As Object
Dim FileNameFolder As Variant
Dim strDate As String
Const strFolder As String = "C:\Path\Unzipped"

    'Create the folder name
    strDate = Format(Now, " dd-mm-yy")
    FileNameFolder = FolderNameUnique(strFolder & strDate & "\")

    'Make the normal folder in DefPath
    CreateFolders CStr(FileNameFolder)
    
    'Extract the files into the newly created folder
    Set oShell = CreateObject("Shell.Application")
    oShell.NameSpace(FileNameFolder).CopyHere oShell.NameSpace(fname).Items
    MsgBox "You will find the unzipped file(s) here: " & FileNameFolder
lbl_Exit:
    Set FSO = Nothing
    Set oShell = Nothing
    Exit Sub
End Sub

Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
End Function

Private Function FolderNameUnique(strPath As String) As String
'An Office macro by Graham Mayor - www.gmayor.com
'Requires the use of the FolderExists function
Dim lngF As Long
Dim lngName As Long
Dim strPathName As String
Dim bSlash As Boolean
    If Right(strPath, 1) = Chr(92) Then
        strPath = Left(strPath, Len(strPath) - 1)
        bSlash = True
    End If
    lngF = 1
    strPathName = strPath
    Do While FolderExists(strPath) = True
        strPath = strPathName & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    'Optionally re-add '\' to the end of the path
    If bSlash = True Then strPath = strPath & Chr(92)
    FolderNameUnique = strPath
lbl_Exit:
    Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If (FSO.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Exit Function
End Function