解压缩文件夹中的 cab 文件，仅某些文件类型并重命名

Question

我正在尝试解决解压缩大量 cab 文件的问题，我设法从不同的脚本创建了一个科学怪人脚本，它可以满足我的需要，但我在弄清楚最后一步时遇到了很多问题，并且我需要稍微推动一下才能使其完美。

我得到了很多 CAB 文件的存档，每个 CAB 都是一个 xml 和一个 txt 文件的存档，每个存档中的名称完全相同。 Zip 文件的文件名中包含序列号。

我设法：

遍历单个文件夹中的所有 cab 文件；
仅从 cab 解压缩 xml 个文件；
将输出放入我想要的硬编码目的地

我需要帮助将我在变量 NameAdd 中提取的序列号附加到提取的 xml 文件中，这样它们就不会在宏循环遍历 cab 文件时覆盖另一个。

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

我尝试在以下代码段的 "oApp.Namespace(Fname).items.Item(CStr(FileNameZip))" 行后添加 &NameAdd，脚本运行没有错误，但没有任何反应 - 出租车没有被提取。我尝试在行后、最后一个括号之后和 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

有没有办法附加 NameAdd 变量，以便文件作为 OriginalName-NameAdd.xml

从存档中出来

任何帮助都会很棒

Answer 1

感谢@Comintern 的建议，问题已经解决。

我通过 NameAdd 变量重命名为 FileNameNew
改为 =Left(Right(Fname, 19), 12) & ".xml"

并在上面的代码片段中添加了另一行

Name FileNameFolder & FileNameZip As FileNameFolder & FileNameNew

解压缩文件夹中的 cab 文件，仅某些文件类型并重命名

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

excel

vba

cab

winzip