我有这样的代码,让我们的用户选择多个zip文件,它会复制所有文件包含一词“未格式化”在它的名称,并把它放在一个文件夹中选择的用户。我不明白为什么它不复制到文件夹。
谢谢你的帮助
Option Explicit
Sub ExtractUnformattedFilesFromZips()
'Ask user to select one or more zip files to extract from
Dim ZipFiles As Variant
ZipFiles = Application.GetOpenFilename(FileFilter:="Zip Files (*.zip), *.zip", Title:="Select one or more zip files to extract from", MultiSelect:=True)
'Ask user to select output folder where "Unformatted" folder will be created
Dim OutputFolder As String
With Application.fileDialog(msoFileDialogFolderPicker)
.Title = "Select output folder where Unformatted folder will be created"
.Show
If .SelectedItems.Count = 1 Then
OutputFolder = .SelectedItems(1)
Else
Exit Sub 'User cancelled or selected more than one folder
End If
End With
'Create Unformatted folder in the output folder
On Error Resume Next 'Avoid error if Unformatted folder already exists
MkDir OutputFolder & "\Unformatted"
On Error GoTo 0
'Loop through each selected zip file and extract files with "unformatted" in the name to the Unformatted folder
Dim ZipFilePath As Variant
Dim UnformattedFolderPath As String
UnformattedFolderPath = OutputFolder & "\Unformatted\"
Dim FileInZip As Variant
Dim ExtractPath As String
For Each ZipFilePath In ZipFiles
If ZipFilePath <> False Then 'User didn't cancel selection
ExtractPath = OutputFolder & "\" & Left$(ZipFilePath, Len(ZipFilePath) - 4) & "\" 'Create subfolder with the same name as the zip file
On Error Resume Next 'Avoid error if subfolder already exists
MkDir ExtractPath
On Error GoTo 0
Debug.Print "Extracting from " & ZipFilePath & " to " & ExtractPath
With CreateObject("Shell.Application").Namespace(ZipFilePath)
For Each FileInZip In .Items
If InStr(1, FileInZip.Name, "unformatted", vbTextCompare) > 0 Then 'File name contains "unformatted"
.CopyHere FileInZip, 16 'Extract file to output folder without prompt and overwrite existing file
Debug.Print "Extracting " & FileInZip.Name & " from " & ZipFilePath & " to " & UnformattedFolderPath
.CopyHere FileInZip, 256 'Extract file to Unformatted folder without prompt and overwrite existing file
Debug.Print "Extracting " & FileInZip.Name & " from " & ZipFilePath & " to " & ExtractPath
End If
Next
End With
End If
Next
'Display message box indicating completion
MsgBox "Extraction complete.", vbInformation
End Sub
1条答案
按热度按时间fwzugrvs1#
这对我很有效: