Using VBA to open a Zip File, Add the name of the Folder to all file names inside and Zip again

[Jambi46n2]

Hello,
Does anyone know of a way using VBA to open a zip file, then add the naming convention the filename to the existing files..

Example:
Zip File: "ZippledFolderName1234.zip"

Contents within before VBA macro:
Filename: "photo1.png"
Filename: "photo2.psd"
Filename: "photo3.png"

Contents after VBA Macro:
Filename: "ZippledFolderName1234_photo1.png"
Filename: "ZippledFolderName1234_photo2.psd"
Filename: "ZippledFolderName1234_photo3.png"

I'm hoping to have something like pasting all the paths of the zip files into Column A, and have them renamed as Column B
Even better if the Macro can detect if the filename is already there in the name and skip it.

I have a 1000 zip files, each with dozens of filenames that need to be renamed.
This would take an eternity to do manually.

Thank you so much in advance.

 

[John_w]

I'm hoping to have something like pasting all the paths of the zip files into Column A, and have them renamed as Column B
Even better if the Macro can detect if the filename is already there in the name and skip it.

Try this macro, which expects the following layout on the active sheet:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If


Public Sub Rename_Files_In_Zip_Files()

    Dim FSO As Object 'Scripting.FileSystemObject
    Dim FStempFolder As Object 'Scripting.Folder
    Dim FSfile As Object 'Scripting.file
    Dim Sh As Object 'Shell32.Shell
    Dim tempFolder As String
    Dim prefix As String, destFile As String
    Dim r As Long, p As Long
    
    Set FSO = CreateObject("Scripting.FileSystemObject") 'New Scripting.FileSystemObject
    Set Sh = CreateObject("Shell.Application") 'New Shell32.Shell
    
    tempFolder = Environ("temp") & "\unzipped"
    
    With ActiveSheet
    
        For r = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            
            'Create empty temporary folder
            
            If FSO.FolderExists(tempFolder) Then FSO.DeleteFolder tempFolder, False
            Set FStempFolder = FSO.CreateFolder(tempFolder)
            
            'Unzip files in the .zip file to the temporary folder
        
            Sh.Namespace((tempFolder)).CopyHere Sh.Namespace((.Cells(r, "A").Value)).Items
            
            'Rename files in the temporary folder with the specified prefix if the file name doesn't start with the prefix
            
            prefix = .Cells(r, "B").Value
            For Each FSfile In FStempFolder.Files
                p = InStrRev(FSfile.Path, "\")
                destFile = Left(FSfile.Path, p) & prefix & Mid(FSfile.Path, p + 1)
                If StrComp(Mid(FSfile.Path, p + 1, Len(prefix)), prefix, vbTextCompare) <> 0 Then
                    FSO.MoveFile FSfile.Path, destFile
                End If
            Next
        
            'Zip files in the temporary folder to the original .zip file
            
            ZipFolder FStempFolder.Path, .Cells(r, "A").Value
        
        Next
    
    End With
    
    If FSO.FolderExists(tempFolder) Then FSO.DeleteFolder tempFolder, False
    
    MsgBox "Done", vbInformation
    
End Sub


'Based on https://stackoverflow.com/questions/42395583/zip-all-files-in-folder-except-the-zip-archive-itself
Private Sub ZipFolder(inputFolder As String, outputZip As String)
    
    Dim Sh As Object 'Shell32.Shell
    Dim tempZip As String
    
    'Delete output .zip file if it already exists
    
    If Dir(outputZip) <> vbNullString Then Kill outputZip

    'Create a temporary .zip file
    
    tempZip = Environ$("temp") & "\" & Format(Time, "hhnnss") & ".zip"
    NewZip tempZip

    'Zip input folder into the temporary .zip file
    'Note - Namespace argument enclosed in brackets to force 'pass by value'
    
    Set Sh = CreateObject("Shell.Application") 'New Shell32.Shell
    Sh.Namespace((tempZip)).CopyHere Sh.Namespace((inputFolder)).Items

    'Rename the temporary .zip file as the output .zip file
    
    On Error Resume Next
    Do Until Dir(outputZip) <> vbNullString
        Sleep 500
        Name tempZip As outputZip
    Loop
    On Error GoTo 0
    
End Sub


'http://www.rondebruin.nl/win/s7/win001.htm
Private Sub NewZip(sPath As String)
    'Create empty Zip File
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

 

[Jambi46n2]

Try this macro, which expects the following layout on the active sheet:

View attachment 75546

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If


Public Sub Rename_Files_In_Zip_Files()

    Dim FSO As Object 'Scripting.FileSystemObject
    Dim FStempFolder As Object 'Scripting.Folder
    Dim FSfile As Object 'Scripting.file
    Dim Sh As Object 'Shell32.Shell
    Dim tempFolder As String
    Dim prefix As String, destFile As String
    Dim r As Long, p As Long
  
    Set FSO = CreateObject("Scripting.FileSystemObject") 'New Scripting.FileSystemObject
    Set Sh = CreateObject("Shell.Application") 'New Shell32.Shell
  
    tempFolder = Environ("temp") & "\unzipped"
  
    With ActiveSheet
  
        For r = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
          
            'Create empty temporary folder
          
            If FSO.FolderExists(tempFolder) Then FSO.DeleteFolder tempFolder, False
            Set FStempFolder = FSO.CreateFolder(tempFolder)
          
            'Unzip files in the .zip file to the temporary folder
      
            Sh.Namespace((tempFolder)).CopyHere Sh.Namespace((.Cells(r, "A").Value)).Items
          
            'Rename files in the temporary folder with the specified prefix if the file name doesn't start with the prefix
          
            prefix = .Cells(r, "B").Value
            For Each FSfile In FStempFolder.Files
                p = InStrRev(FSfile.Path, "\")
                destFile = Left(FSfile.Path, p) & prefix & Mid(FSfile.Path, p + 1)
                If StrComp(Mid(FSfile.Path, p + 1, Len(prefix)), prefix, vbTextCompare) <> 0 Then
                    FSO.MoveFile FSfile.Path, destFile
                End If
            Next
      
            'Zip files in the temporary folder to the original .zip file
          
            ZipFolder FStempFolder.Path, .Cells(r, "A").Value
      
        Next
  
    End With
  
    If FSO.FolderExists(tempFolder) Then FSO.DeleteFolder tempFolder, False
  
    MsgBox "Done", vbInformation
  
End Sub


'Based on https://stackoverflow.com/questions/42395583/zip-all-files-in-folder-except-the-zip-archive-itself
Private Sub ZipFolder(inputFolder As String, outputZip As String)
  
    Dim Sh As Object 'Shell32.Shell
    Dim tempZip As String
  
    'Delete output .zip file if it already exists
  
    If Dir(outputZip) <> vbNullString Then Kill outputZip

    'Create a temporary .zip file
  
    tempZip = Environ$("temp") & "\" & Format(Time, "hhnnss") & ".zip"
    NewZip tempZip

    'Zip input folder into the temporary .zip file
    'Note - Namespace argument enclosed in brackets to force 'pass by value'
  
    Set Sh = CreateObject("Shell.Application") 'New Shell32.Shell
    Sh.Namespace((tempZip)).CopyHere Sh.Namespace((inputFolder)).Items

    'Rename the temporary .zip file as the output .zip file
  
    On Error Resume Next
    Do Until Dir(outputZip) <> vbNullString
        Sleep 500
        Name tempZip As outputZip
    Loop
    On Error GoTo 0
  
End Sub


'http://www.rondebruin.nl/win/s7/win001.htm
Private Sub NewZip(sPath As String)
    'Create empty Zip File
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

This worked beautifully!
You have saved me so much time and stress before a tight deadline.
I can't thank you enough!