Question

我正在尝试解决许多cab文件解压缩的问题，我设法从下面的脚本中创建了一个弗兰肯斯坦脚本，该脚本可以满足我的需要，但是我在确定最后一步时遇到了很多问题，我需要轻拍以使其完美。

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

我设法做到了

循环浏览单个文件夹中的所有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文件（仅某些文件类型）并重命名

1 个答案: