excelvbacabwinzip

Unzip cab files in a folder, only certain filetypes and rename

I am trying to solve a unzipping a lot of cab files problem and I managed to create a frankenstein script below from different scripts that does what i need but I am having a lot of problems figuring out the very last step and I need a lil nudge to make it perfect.

I get an archive of a lot of CAB files and each CAB is an archive of one xml and one txt file that has the exact same name in every archive. Zip files have serial number as part of the filename.

I managed to:

  1. loop through all cab files in a single folder;
  2. unzip only xml files from cab;
  3. put the output into a hardcoded destination I wanted

I need help with appending the serial number I extract in variable NameAdd to the extracted xml file so they dont overwrite one over another as the macro loops through the cab files. 

Sub UnarchiveCabs()

Dim str_FILENAME As String, str_DIRECTORY As String, str_DESTINATION As String

'cab archives folder
str_DIRECTORY = "C:\Users\vp1\Desktop\input\"

'Loop through all cab files in a given directory
str_FILENAME = Dir(str_DIRECTORY & "*.cab")

Do While Len(str_FILENAME) > 0
Call UnarchiveCabsSub(str_DIRECTORY & str_FILENAME)
Debug.Print str_FILENAME
str_FILENAME = Dir
Loop

End Sub

Sub UnarchiveCabsSub(str_FILENAME As String)
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Dim FileNameZip As Variant
Dim NameAdd As String

'Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                    MultiSelect:=False)
Fname = str_FILENAME
NameAdd = Left(Right(Fname, 19), 12)

If Fname = False Then
    'Do nothing
Else
    'Root folder for the new folder.
    DefPath = "C:\Users\vp1\Desktop\input\xml\"
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If


    FileNameFolder = DefPath    'I want them in hardcoded folder

    Set oApp = CreateObject("Shell.Application")

    'if you want to extract all without conditions
    'oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items

    'If you want to extract only one file you can use this:
    'oApp.Namespace(FileNameFolder).CopyHere _
     'oApp.Namespace(Fname).items.Item("filename.txt")

    'Change this "*.xml" to extract the type of files you want
    For Each FileNameZip In oApp.Namespace(Fname).items
        If LCase(FileNameZip) Like LCase("*.xml") Then
            oApp.Namespace(FileNameFolder).CopyHere _
                    oApp.Namespace(Fname).items.Item(CStr(FileNameZip))
        End If
    Next


    'MsgBox "You find the files here: " & FileNameFolder
    Debug.Print "You find the files here: " & FileNameFolder

    On Error Resume Next
    Set FSO = CreateObject("scripting.filesystemobject")
    FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub

I tried adding &NameAdd after line "oApp.Namespace(Fname).items.Item(CStr(FileNameZip))" in the following snippet and script runs without errors but nothing happens - cabs dont get extracted. I tried adding it after line, after last parenthesis and after FileNameZip

For Each FileNameZip In oApp.Namespace(Fname).items
    If LCase(FileNameZip) Like LCase("*.xml") Then
        oApp.Namespace(FileNameFolder).CopyHere _
                oApp.Namespace(Fname).items.Item(CStr(FileNameZip))
    End If
Next

Is there a way to append that NameAdd variable so that files come out of archives as OriginalName-NameAdd.xml

Any assistance would be amazing

Solution

  • Thanks to a suggestion by @Comintern the issue has been resolved.

    I renamed by NameAdd variable to FileNameNew
    Chanaged it to =Left(Right(Fname, 19), 12) & ".xml"

    And added another line in the snippet above

    Name FileNameFolder & FileNameZip As FileNameFolder & FileNameNew