Microsoft Office Forums - View Single Post - Save and rename attachments from ZIP FILE

gmayor · 03-03-2016, 12:32 AM

The following will extract the workbook from the zip attachment and save it in the named folder at the top of the code, renamed as you requested. For it to work as intended the zip file name must relate to that in your post, or the results will vary.

The macro assumes only one zip file and only one workbook in the zip.

The first macro will allow you to test the code. The second is used as a script associated with a rule to identify the messages, which are thus processed on arrival.

The remainder are functions associated with the process.

The macro runs very quickly without any obvious sign of activity.

Code:

Option Explicit
Public Const strSaveFldr As String = "C:\RenamedExtracts\"

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

Private Sub SaveAttachments(olItem As MailItem)
'An Outlook macro by Graham Mayor
'www.gmayor.com
Dim olAttach As Attachment
Dim strFname As String
Dim j As Long
Dim strTempFolder As String
    strTempFolder = Environ("Temp") & Chr(92)

    CreateFolders strSaveFldr
    On Error GoTo CleanUp
    If olItem.Attachments.Count > 0 Then
        For j = olItem.Attachments.Count To 1 Step -1
            Set olAttach = olItem.Attachments(j)
            If Right(olAttach.FileName, 3) = "zip" Then
                strFname = olAttach.FileName
                olAttach.SaveAsFile strTempFolder & strFname
                Exit For
            End If
        Next j
        Unzip strTempFolder & strFname
        Kill strTempFolder & strFname        'Delete the zip from the temporary location
    End If
CleanUp:
    Set olAttach = Nothing
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub

Sub Unzip(fName As Variant)
'An Outlook macro by Graham Mayor
'www.gmayor.com
Dim oApp As Object
Dim vFolder As Variant
Dim strName As String
Dim strNewName As String
Dim vFname As Variant
    If Not fName = False Then
        vFolder = strSaveFldr
        Set oApp = CreateObject("Shell.Application")
        For Each vFname In oApp.NameSpace(fName).Items
            If LCase(vFname) Like LCase("*.xls") Then
                oApp.NameSpace(vFolder).CopyHere _
                        oApp.NameSpace(fName).Items.Item(CStr(vFname))
                strName = vFolder & vFname
                strNewName = Right(fName, Len(fName) - InStrRev(fName, Chr(92)))
                strNewName = Format(Date, "yyyy-mm-dd_") & strNewName
                strNewName = Replace(strNewName, "From", "")
                strNewName = vFolder & Replace(strNewName, ".zip", ".xls")
                Name strName As strNewName
                Exit For
            End If
        Next
    End If
lbl_Exit:
    Set oApp = Nothing
    Exit Sub
End Sub

Private Function FolderExists(fldr) As Boolean
'An Outlook 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:
    Set FSO = Nothing
    Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook 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