用于解压缩文件的VBA脚本 - 它只是创建空文件夹

时间:2013-11-06 10:03:06

标签: vba excel-vba zip unzip excel

我正在使用Ron(http://www.rondebruin.nl/win/s7/win002.htm)的代码,理论上将一堆zip文件解压缩到一个文件夹中。我相信我下面的代码是将每个zip文件放在我的“下载”目录中,创建一个新文件夹,其中包含没有“.zip”的zip文件的名称,然后将文件提取到新文件夹中。我没有得到任何错误(很多时候人们得到​​运行时错误91)但唯一发生的事情是它创建了一堆正确命名的文件夹,但它们都是空的。

Sub UnZipMe()

Dim str_FILENAME As String, str_DIRECTORY As String, str_DESTINATION As String

'Your directory where zip file is kept
str_DIRECTORY = "C:\Users\Jennifer\Downloads\"

'Loop through all zip files in a given directory
str_FILENAME = Dir(str_DIRECTORY & "*.zip")

Do While Len(str_FILENAME) > 0
    Call Unzip1(str_DIRECTORY & str_FILENAME)
    Debug.Print str_FILENAME
    str_FILENAME = Dir
Loop

End Sub

Sub Unzip1(str_FILENAME As String)
    Dim oApp As Object
    Dim Fname As Variant
    Dim FnameTrunc As Variant
    Dim FnameLength As Long

    Fname = str_FILENAME
    FnameLength = Len(Fname)
    FnameTrunc = Left(Fname, FnameLength - 4) & "\"

    If Fname = False Then
        'Do nothing
    Else
        'Make the new folder in root folder
        MkDir FnameTrunc

        'Extract the files into the newly created folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FnameTrunc).CopyHere oApp.Namespace(Fname).items
    End If
End Sub

1 个答案:

答案 0 :(得分:1)

问题是你没有给windows足够的时间来解压缩zip文件。在行之后添加DoEvents,如下所示。

已经过测试

    oApp.Namespace(FnameTrunc).CopyHere oApp.Namespace(Fname).items
    DoEvents