(Rule) save attachment then extract using 7zip

Hi

I am trying to create a script in Outlook that runs on all new messages with attachment.
I want it to :

1. save attachment (I know it will be a password protected zip file)
2. extract contents of zip file using 7zip to specofic location

I've been fiddling with the following code, but I can't seem to get it to work.. it does save the attachment but it doesn't extract the contents.. sometimes I can get it to extract but 7zip prompts every time that the file exists and would I like to overwrite it/Quit etc. even though I am 100% sure the target file isn't in the location..
I regret to admit that I have NO knowledge about VBA.. at all.. I usually work in Powershell... The below code I gleaned from the internet and just kindda tried stuff.. :-)
I am hoping someone will correct the code so I have a usable script..

here's the code:

Code:

---

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:\temp"
Dim objShell As Object

    Set objShell = CreateObject("Wscript.Shell")
    For Each objAtt In itm.Attachments
          objAtt.SaveAsFile saveFolder & "\" & objAtt.FileName
          objShell.Run """C:\Program Files\7-Zip\7z.exe"" e -aoap56suwBfbNd & saveFolder & " \ " & objAtt.FileName & """""
          Set objAtt = Nothing
          Set objShell = Nothing
    Next
End Sub

---

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.

Code:

---

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

---

Hi Graham.

A Huge thank you.
I haven't tested anything yet but to answer some of your thoughts:

there will only be one type of attachment and only the same password.
i just created a rule saying from this sender, while having attachment .
basically the sender & attachment is the same and rule will only apply to that specific rule set.

only thing I wish is that it wasn't client side:-/
i look forward to testing your code on Monday!

You will probably have to sign the project client side - http://www.gmayor.com/create_and_emp...gital_cert.htm

Having the same password each time makes things easier, but be aware that there can be images (e.g. from a signature) in the attachment collection, so you will need to loop through the attachments to ensure you process only the Zip or things will get 'interesting'.

While transcribing the code and describing the process for my web site - http://www.gmayor.com/extract_files_...ttachments.htm
I discovered that the command line processor would create the files whether or not there was a password, but where the password was incorrect or missing the files were of zero bytes length, and thus useless and in the way of correct extraction.

I used this to allow the files to be extracted correctly with no password, a default password or a prompted password, with any invalid zero byte files removed. The updated code is on my web site at the above link.

Hi Graham

So I've been trying to get your code to work..

here's my progress so far..

I downloaded the .bas file from your site.
I imported it into outlook VBA
I changed the relevant parts in the code.. and I deleted the "unzip without password" part.. I assume I needed to keep the one I want to use and remove the other..
But.. looking at the code it appeard that the "unzip without password" does the same as the one with password.. at least it has the -p parameter as well..

As far as I can read you also remembered to NOT add space between -p & the password (-pMySecretPass)

I created a new rule and applied the script.. but nothing happened...

I don't get any popup messages or anything else.. When I select "run rule now" from outlook it does run.. but nothing happens ... not msgbox or anything else...

I enabled ALL macros at this stage but that doesn't seem to help either... it doesn't even create the folders..

any thougts?

Attachment 15718Attachment 15719

hm... disabling Macros and THEN restarting outlook helped... it 'werks!!

I signed the vba project...
So now I need to export it and give it to the user that needs it..
any way to avoid having to accept the warning about macros?
I used a domain code signing certificate (stored in my personal cert. store) to sign it...

Hm.. the script started prompting with an error on this line:

RmDir strPath

It was extracting some zip files that wan't "part of the plan" since I hadn't narrowed down my rule yet.. I cannot recreate it though :-|

damnit.. I need to point the save folder to an UNC path.
The script doesn't seem to like that.. at all.. :-|

Code:

---

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

---

I have not worked with any of the processes and UNC paths. It should work if the networked folder is mapped to a Windows drive letter.

It was not necessary, nor desirable, to remove sections of code relating to passwords as this was part of the error trapping. You can enter your common password at the start of the sub in the updated version from my web site in the line

Code:

---

Const sDefaultPassword As String = "#test#" 'Change as                      required

---

Use the test macro to test the process. If that works, then provided your rule identifies the messages correctly it will only process those messages on arrival.

You can remove the alternative Private Sub UnZipFile(vFname As Variant) as this is just included for completeness and is not required by the process.

Unless the user has a valid certificate correctly installed and used to sign the project it will not work correctly. My web page has instructions.

Hi Graham.
Thx, yes if I have a mapped network drive it does work. I would just very much prefer to point directly to shared folder so I don't need to mount a network drive for this single purpose.
So using UNC's isn't as easy as that?

Replace the CreateFolders process with the following which will write to UNC file paths:

Code:

---

Private Sub CreateFolders(strPath As String)
Dim lngPathSep As Long
Dim lngPS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lngPathSep = InStr(3, strPath, "\")
    If lngPathSep = 0 Then GoTo lbl_Exit
    Do
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
        If lngPathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lngPathSep = 0
        MkDir Left(strPath, lngPathSep)
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
    Loop
lbl_Exit:
    Exit Sub
End Sub

---

OMG... it does exactly what I want...

Now to test some more before taking it Live..

Graham this is fantastic!! it'll save quite a lot of clicks moving forward.. thank you so much!!

last step will be to replace my code with your updated code and add the network snippet to the 'new' code...

Graham you've been tremendously helpful!