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

Question

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

我得到了很多 CAB 文件的存档，每个 CAB 是一个 xml 和一个 txt 文件的存档，每个存档中具有完全相同的名称。 Zip 文件将序列号作为文件名的一部分。

我设法：

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

我需要帮助将我在变量 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

我尝试在以下 sn-p 中的“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"

并且在上面的sn-p中又加了一行

Name FileNameFolder & FileNameZip As FileNameFolder & FileNameNew