VBA для извлечения нескольких файлов ZIP - PullRequest
Новая
       30

VBA для извлечения нескольких файлов ZIP

0 голосов
/ 20 апреля 2020

Я работаю на VBA, где мне нужно извлечь все ZIP-файлы, которые находятся в одной папке. Мне нужно иметь возможность извлечь каждый zip-файл, чтобы извлечь в него соответствующую папку (необходимо создать папку на основе имени zip-файла).

На основе приведенного ниже кода я могу извлечь первый zip-файл и затем происходит ошибка с кодом «myFile - Dir»

Пожалуйста, кто-нибудь может помочь здесь 

Sub Unzip()
Dim oApplicationlication As Object
Dim MyFolder As String
Dim MyFile As String
Dim ZipFile As Variant
Dim ExtractTo As Variant


Application.ScreenUpdating = False

'Cell B2 is the folder path which contains all zip file

MyFolder = Range("B2")
MyFile = Dir(MyFolder & "\*.zip")
ZipFile = Range("C2")
ExtractTo = Range("B3")

Do While MyFile <> ""

'Cell C2 is updated with a zip file name via loop function

Range("C2") = MyFolder & "\" & MyFile

 If Len(Dir(Range("B3"), vbDirectory)) = 0 Then
   MkDir Range("B3")
End If

 Set oApplication = CreateObject("Shell.Application")
 oApplication.Namespace(ExtractTo).CopyHere oApplication.Namespace(ZipFile).Items
 DoEvents

MyFile = Dir

Loop

Application.ScreenUpdating = True


End Sub

Ответы [ 2 ]

1 голос
/ 20 апреля 2020

Вот ваш точно такой же код, использующий объект файловой системы вместо того, чтобы выполнять работу с папками внутри l oop. Я не проверял это, но это иллюстрирует то, о чем я говорю в моем комментарии выше. Вы должны быть в состоянии заставить его работать, используя это: 

Sub Unzip()
Dim oApplicationlication As Object
Dim MyFolder As String
Dim MyFile As String
Dim ZipFile As Variant
Dim ExtractTo As Variant

' create the fso
Dim fso as Object
Set fso = CreateObject("Scripting.FileSystemObject")

Application.ScreenUpdating = False

'Cell B2 is the folder path which contains all zip file

MyFolder = Range("B2")
MyFile = Dir(MyFolder & "\*.zip")
ZipFile = Range("C2")
ExtractTo = Range("B3")

Do While MyFile <> ""

'Cell C2 is updated with a zip file name via loop function

Range("C2") = MyFolder & "\" & MyFile


' use the fso to check for and create the folder
' this way you dont have to use the DIR function again, which was messing things up
If Not fso.FolderExists(Range("B3")) Then
   fso.CreateFolder(Range("B3"))
End If

 Set oApplication = CreateObject("Shell.Application")
 oApplication.Namespace(ExtractTo).CopyHere oApplication.Namespace(ZipFile).Items
 DoEvents

MyFile = Dir

Loop

Application.ScreenUpdating = True


End Sub

Вы также можете извлечь выгоду (в зависимости от скорости, в зависимости от того, сколько существует zip-файлов) от перемещения этой строки за пределы l oop и поместите его сверху, где создается объект fso. 

Set oApplication = CreateObject("Shell.Application")
0 голосов
/ 20 апреля 2020

Ваш код не выполняется, потому что вы используете Dir в l oop, чтобы проверить наличие папки для извлечения. Вместо этого переместите этот фрагмент кода за пределы l oop: 

Sub Unzip()
    Dim oApplication As Object
    Dim MyFolder As String
    Dim MyFile As String
    Dim ExtractTo As Variant
    Application.ScreenUpdating = False
    'Cell B2 is the folder path which contains all zip file
    If Len(Dir(Range("B3"), vbDirectory)) = 0 Then
        MkDir Range("B3")
    End If
    MyFolder = Range("B2")
    If Right(MyFolder, 1) <> "\" Then MyFolder = MyFolder & "\"
    MyFile = Dir(MyFolder, vbNormal)
    ExtractTo = Range("B3")
    Do While MyFile <> ""
    'Cell C2 is updated with a zip file name via loop function
        If Right(MyFile, 3) = "zip" Then
            Range("C2") = MyFolder & MyFile
            Set oApplication = CreateObject("Shell.Application")
            oApplication.Namespace(ExtractTo).CopyHere oApplication.Namespace(MyFolder & MyFile).Items
            DoEvents
        End If
        MyFile = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Regards,

...