Используйте Excel VBA для распаковки файлов - PullRequest
Новая
       45

Используйте Excel VBA для распаковки файлов

0 голосов
/ 09 июля 2020

Я нашел этот код в другом сообщении о переполнении стека, и он работает хорошо, но код предлагает пользователю выбрать файл, можно ли его изменить, чтобы он автоматически распаковывал все файлы в выбранном каталоге?

Распаковать папку с файлами в выбранное место 

Sub Unzip()
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String

    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=False)
    If Fname = False Then
        'Do nothing
    Else
        'Destination folder
        DefPath = "C:\test\"    ' Change to your path / variable
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

        FileNameFolder = DefPath

        '        'Delete all the files in the folder DefPath first if you want
        '        On Error Resume Next
        '        Kill DefPath & "*.*"
        '        On Error GoTo 0

        'Extract the files into the Destination folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items

        MsgBox "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

Теперь с добавленным l oop, поскольку brax отлично указывает на то, что я могу использовать это, но все еще не решает проблема с запросом пользователя, какой файл открыть 

Sub Unzip5()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String

Dim StrFile As String
StrFile = Dir("Z:\G Thang\Excel & VBA\Extract\*.zip")
Do While Len(StrFile) > 0

Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                        MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Destination folder
DefPath = "Z:\G Thang\Excel & VBA\Extract\" ' Change to your path / variable
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameFolder = DefPath
' 'Delete all the files in the folder DefPath first if you want
' On Error Resume Next
' Kill DefPath & "*.*"
' On Error GoTo 0
'Extract the files into the Destination folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
MsgBox "You find the files here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True

End If

Loop

End Sub

хорошо, я понял! Но мой новый код проходит через один и тот же файл и продолжает распаковывать его, может быть, я смогу переместить его в другой каталог, когда я закончу распаковывать его, а затем перейти к следующему, я отправлю код ниже. 

Sub Unzip99File()


Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim StrFile As String

StrFile = Dir("Z:\G Thang\Excel & VBA\Extract\*.zip")
'Fname = ("*.zip")
    Do While Len(StrFile) > 0
    
        Fname = ("*.zip")
        
            If Fname = False Then                           'Fname
                'Do nothing
                Else
                'Destination folder
                DefPath = "Z:\G Thang\Excel & VBA\Extract\" ' Change to your path / variable
              '  If Right(DefPath, 1) <> "\" Then
               ' DefPath = DefPath & "\"
                ' End If
        FileNameFolder = DefPath
        ' 'Delete all the files in the folder DefPath first if you want
        ' On Error Resume Next
        ' Kill DefPath & "*.*"
        ' On Error GoTo 0
        
        'Extract the files into the Destination folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(DefPath & StrFile).items

        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
        
        End If
    
    Loop

End Sub
...