Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 03-02-2016, 04:37 AM
AndyDDUK AndyDDUK is offline Save and rename attachments from ZIP FILE Windows 7 64bit Save and rename attachments from ZIP FILE Office 2010 64bit
Advanced Beginner
Save and rename attachments from ZIP FILE
 
Join Date: Oct 2012
Posts: 32
AndyDDUK is on a distinguished road
Default Save and rename attachments from ZIP FILE

Office 2013



Hi

I've seen several bits of code for saving and renaming attachments in Outlook but I can't get them to work for me

Reason is that I need VBA code to extract and rename files sent as a zip file attachment

For example, if I have a file called "FromCompanyA.zip" which contains a xls file called 01222.xls, I need this xls file renamed as yyyy-mm-dd_CompanyA.xls format

(yyyy-mm-dd is the creation date of the file name)


Zip files saved to eg C:\ZipFilesreceived
Renamed extracted files saved to C:\RenamedExtracts

Can you help me by supplying code?

Many thanks

Andy
Reply With Quote
  #2  
Old 03-03-2016, 12:32 AM
gmayor's Avatar
gmayor gmayor is offline Save and rename attachments from ZIP FILE Windows 10 Save and rename attachments from ZIP FILE Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

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
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Macro to rename multiple Word file with same suffix ozil61 Word VBA 2 05-06-2014 07:36 AM
Save and rename attachments from ZIP FILE Have to rename file every time to save workbook intelli Excel 3 03-27-2014 11:53 PM
Save and rename attachments from ZIP FILE Rename Document & Save d4okeefe Word VBA 4 05-23-2013 09:35 AM
Save and rename attachments from ZIP FILE Rename File cksm4 Word VBA 2 02-25-2011 09:29 AM
Save and rename attachments from ZIP FILE code to save / rename / send attachments unit213 Outlook 1 09-26-2007 08:15 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 12:11 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft