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

我正试图解决一个解压很多cab文件的问题，我设法从不同的脚本中创建了一个下面的弗兰肯斯坦脚本，它可以满足我的需要，但我在确定最后一步时遇到了很多问题，我需要轻轻推一下，使之完美

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

我设法：

循环浏览单个文件夹中的所有cab文件

仅从cab解压缩xml文件

将输出放入我想要的硬编码目标

我需要帮助将我在变量名add中提取的序列号附加到提取的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

有没有一种方法可以附加NameAdd变量，以便文件以OriginalName-NameAdd.xml的形式从存档中出来

---

任何援助都将是惊人的

多亏了@Comintern的建议，问题已经解决了

我重命名为

name将
变量添加到
filenamew


将其更改为
=左（右（Fname，19），12）和“.xml”

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

Name FileNameFolder & FileNameZip As FileNameFolder & FileNameNew 

提取后重命名每个文件。瞧，先生，你是个天才。我将Name变量改为Left（Right（Fname，19），12）和“.xml”，并添加了另一行：Name FileNameFolder&FileNameZip As FileNameFolder&FileNameNewNP，很高兴您对其进行了排序。请注意，您可以将自己的答案标记为solution，以便进一步的读者看到问题已经解决。
Name FileNameFolder & FileNameZip As FileNameFolder & FileNameNew