Graham Mayor
... helping to ease the lives of Microsoft Word users.
 |
 |
 |
Many people access the material from this web site daily. Most just take what they want and run. That's OK, provided they are not selling on the material as their own; however if your productivity gains from the material you have used, a donation from the money you have saved would help to ensure the continued availability of this resource. Click the appropriate button above to access PayPal.
Outlook - Automatically extract files from e-mailed ZIP files
A forum subscriber wanted to automatically extract the data from zipped files e-mailed to him, which I thought was an interesting project worthy of publication on this web site.
The user also wanted to employ the third party open source zip processor 7-Zip which is available from https://sourceforge.net/projects/sevenzip/files/latest/download
This version installs in the folder C:\Program Files (x86)\7-Zip, however at least one other version I tested installs in the folder C:\Program Files\7-Zip so ensure that this is correctly addressed in the code reproduced below.
It is possible to extract files from zips without using a third party product, but 7-Zip brings to the table a particularly useful attribute, in that it has a command line processor with which you can send a password to the zip to avoid the prompt on protected zips.
This ability is not without issues, for if you enter the wrong password, or no password, when processing a protected zip, the files are still extracted, but they are of zero length. My approach to the problem ensures that such files are identified and removed.
I have also included code for extracting zips without the third party application, but it will not extract from protected zips.
The process uses an assortment of linked processes, some of which are already featured on this site but I have reproduced them here for completeness.
The main code can be linked as a script from an Outlook rule, to process the messages as they arrive, only prompting for a password when one is required to extract the data.
If Outlook rules dialog does not display the option to
run a script, it is an indication that a
security setting is in force. You can address this with a
registry hack:
1. Click Start - Search, type ‘regedit’ (Note: there are no quotation marks in the command.) and press Enter.
2. Navigate to HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Security. (where 16 is the Office version - here 2016)
3. Right-click a blank area, create a new DWORD Value named as ‘EnableUnsafeClientMailRules’ and set it to 1.
Alternatively you could run the following macro to apply the
registry setting described.
Dim WSHShell As Object
Dim rKeyWord As String
Dim wVer As String
Dim RegKey As String
Dim strItem As String
strItem = "EnableUnsafeClientMailRules"
RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Outlook\Security\"
Debug.Print RegKey
End
Set WSHShell = CreateObject("WScript.Shell")
Start:
On Error Resume Next
rKeyWord = WSHShell.RegRead(RegKey & strItem)
Select Case rKeyWord
Case Is = "1"
MsgBox "Outlook Rules Security Check is Off"
Case Else
WSHShell.RegWrite RegKey & strItem, 1, "REG_DWORD"
MsgBox "Outlook Rules Security Check is Off"
End Select
lbl_Exit:
Exit Sub
End Sub
Some users will habitually be receiving zip files with the same password, so you may enter this password as the default into the code.
The process first attempts to extract the files using no password. If a password was required, the process still writes the files to the appropriate folder, but of zero bytes length. This is used to establish whether then files are valid. If they are not then the files (but not the folder) are deleted and the process tries again with the default password. Again if the password is inappropriate the files are deleted and the process prompts for a password.
If the password is correctly entered (or was not required) the user receives a message to indicate where the files are located. You may delete this message if you wish.
If, at the final hurdle, the password proves to be incorrect, the files and the folder are deleted and the user is informed of the failure.
The extracted files are created in a sub folder of the folder defined at:
Const sFolder As String = "C:\Path\Unzipped Files"
This folder and its sub folders are created by the code if not present. You may change the above line to reflect your personal requirements.
The zipped files sub folder is named with the date and the original zip file name. Should this folder exist, e.g. if two similarly named files are processed on the same day, the folder name is appended with an incrementing number e.g.
C:\Path\Unzipped Files\Forums.zip 20-03-16
and
C:\Path\Unzipped Files\Forums.zip 20-03-16(1)
You can change the date format in the code to suit local requirements, however be aware of illegal filename characters which may not be inserted into a folder name e.g. 20/03.2016 is not a valkid date for this purpose.
The code is also available as a module to import into Outlook
You will undoubtedly have to digitally sign your Outlook project when using this code, to avoid macro warnings each time you use it - see how to create and employ a digital certificate
#If Win64 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub TestUnzip()
'An Outlook macro by Graham Mayor - www.gmayor.com
'Use this macro to test the process with a selected message
Dim olMsg As MailItem
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
'Folder to save temporary files
strPath = Environ("Temp") & "\ZipTemp"
If Item.Attachments.Count > 0 Then
For Each olAtt In Item.Attachments
If Right(LCase(olAtt.FileName), 3) = "zip" Then
'Create the temporary folder
CreateFolders strPath
olAtt.SaveAsFile strPath & olAtt.FileName
'UnZipFile strPath & olAtt.FileName 'This line may be used to call the alternative process to that called in the next line
UnzipWithPassword strPath & olAtt.FileName
'Remove the temporary file
Kill strPath & olAtt.FileName
End If
Next olAtt
'Remove the temporary folder
RmDir strPath
End If
lbl_Exit:
Set olAtt = Nothing
Exit Sub
End Sub
Private Sub UnzipWithPassword(vFname As Variant)
Dim vFileFolder As Variant
Dim sDate As String
Dim sPathToExe As String
Dim sPassword As String
Dim sPath As String
Const sDefaultPassword As String = "#test#" 'Change as required
Const sFolder As String = "C:\Path\Unzipped Files"
sPathToExe = "C:\Program Files (x86)\7-Zip\7z.exe"
sPath = CStr(vFname)
sPath = Right(sPath, Len(sPath) - InStrRev(sPath, Chr(92)))
'Create the folder name
sDate = Format(Now, " dd-mm-yy")
vFileFolder = FolderNameUnique(sFolder & Chr(92) & sPath & Chr(32) & sDate & Chr(92))
'Make the folder path to save the extracted files
CreateFolders CStr(vFileFolder)
'Set a null paswword
sPassword = ""
'Try and extract the files without a password
Shell sPathToExe & " x -y -p" & sPassword & " -o""" & _
vFileFolder & """ """ & vFname, vbHide
'Wait half a second (you may need longer depending on the disc write speed)
Sleep 500
'The function will extract the files, but if they were password protected they will be of zero length
'So check the file lengths
If FolderValid(CStr(vFileFolder)) Then
MsgBox "You will find the files here: " & vFileFolder
Else
Kill CStr(vFileFolder) & "*.*"
'And enter the default password
sPassword = sDefaultPassword
'Try and extract the files with the default password
Shell sPathToExe & " x -y -p" & sPassword & " -o""" & _
vFileFolder & """ """ & vFname, vbHide
'Wait half a second (you may need longer depending on the disc write speed)
Sleep 500
'Check again to establish whether the extracted files are valid
If FolderValid(CStr(vFileFolder)) Then
'Job done!
MsgBox "You will find the files here: " & vFileFolder
Else
'The files are still invalid, so the password entered was probably wrong
'The files are invalid, so delete them
Kill CStr(vFileFolder) & "*.*"
'And prompt for the password
sPassword = InputBox("Enter the password for the zip file")
'Try and extract the files with the password
Shell sPathToExe & " x -y -p" & sPassword & " -o""" & _
vFileFolder & """ """ & vFname, vbHide
'Wait half a second (you may need longer depending on the disc write speed)
Sleep 500
'Check again to establish whether the extracted files are valid
If FolderValid(CStr(vFileFolder)) Then
'Job done!
MsgBox "You will find the files here: " & vFileFolder
Else
'The files are still invalid, so the password entered was probably wrong
MsgBox "The process was unable to unzip the files." & _
vbCr & "Did you enter the correct password?", vbInformation, _
"Extract Files from Zipped attachment"
'So delete the files and the folder
Kill CStr(vFileFolder) & "*.*"
RmDir CStr(vFileFolder)
End If
End If
End If
lbl_Exit:
Set vFileFolder = Nothing
Exit Sub
End Sub
Private Sub UnZipFile(vFname As Variant)
'An Office macro by Graham Mayor - www.gmayor.com
'This is a less sophisticated process that doesn't require the third party 7-Zip application
'Use where the ZIP files are not password protected.
Dim FSO As Object
Dim oShell As Object
Dim sPath As String
Dim vFileFolder As Variant
Dim sDate As String
Const sFolder As String = "C:\Path\Unzipped Files"
On Error GoTo lbl_Exit
'Create the folder name
sPath = CStr(vFname)
sPath = Right(sPath, Len(sPath) - InStrRev(sPath, Chr(92)))
'Create the folder name
sDate = Format(Now, " dd-mm-yy")
vFileFolder = FolderNameUnique(sFolder & Chr(92) & sPath & Chr(32) & sDate & Chr(92))
'Make the folder path to save the extracted files
CreateFolders CStr(vFileFolder)
'Extract the files into the newly created folder
Set oShell = CreateObject("Shell.Application")
oShell.NameSpace(vFileFolder).CopyHere oShell.NameSpace(vFname).Items
MsgBox "You will find the unzipped file(s) here: " & vFileFolder
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
Function FileSize(filespec) As Long
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
Dim oFile As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFile = FSO.GetFolder(filespec)
FileSize = oFile.Size
lbl_Exit:
Set FSO = Nothing
Set oFile = Nothing
Exit Function
End Function
Function FolderValid(strPath As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim strfile As String
On Error GoTo err_Handler
strfile = Dir$(strPath & "*.*")
Do While strfile <> ""
If FileLen(strPath & strfile) > 0 Then
FolderValid = True
Exit Do
End If
strfile = Dir$()
Loop
lbl_Exit:
Exit Function
err_Handler:
FolderValid = False
Err.Clear
GoTo lbl_Exit
End Function
Extract Files from ZIP
This page features example code, for experienced VBA users, to demonstrate the extraction of files from zipped attachments in Outlook.