office交流網(wǎng)--QQ交流群號(hào)及微信交流群

Access培訓(xùn)群:792054000         Excel免費(fèi)交流群群:686050929          Outlook交流群:221378704    

Word交流群:218156588             PPT交流群:324131555

微信交流群(請(qǐng)用微信掃碼)

        

VBA直接解壓文件(不支持壓縮)

2017-09-07 08:20:00
zstmtony
原創(chuàng)
4018
警告:
本代碼不受微軟技術(shù)支持。當(dāng)你從一個(gè)壓縮文件復(fù)制文件時(shí)會(huì)出現(xiàn)一個(gè)復(fù)制對(duì)話筐 (僅在對(duì)普通文件夾進(jìn)行操作時(shí)),而且用戶可以取消此復(fù)制操作。

提示:
不要定義示例中的 strFileNameFolder 變量為String 類型,必須定義為 Variant 類型, 否則代碼不能正常運(yùn)行。

示例 1:
通過此例你可以瀏覽壓縮文件.你選中一個(gè)文件后此宏會(huì)在你的默認(rèn)文件路徑下創(chuàng)建一個(gè)新的文件夾并解壓文件到這個(gè)文件夾。


Sub UnzipFile()
    Dim FSO As Object
    Dim oApp As Object
    Dim strFileName As Variant
    Dim strFileNameFolder As Variant
    Dim strDefPath As String
    Dim strDate As String
    '只支持Zip壓縮文件,不支持Rar或其它壓縮格式
    strFileName = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=False)
    If Not (strFileName = False)Then
        '新文件夾的上級(jí)文件夾.
        '你也可以支持指定路徑 strDefPath = "C:\Users\test"
        strDefPath = Application.DefaultFilePath
        If Right(strDefPath, 1) <> "" Then
            strDefPath = strDefPath & ""
        End If
        '創(chuàng)建文件夾名稱
        strDate = Format(Now, " dd-mm-yy h-mm-ss")
        strFileNameFolder = strDefPath & "MyUnzipFolder " & strDate & ""
        '創(chuàng)建名為 strDefPath 的普通文件夾
        MkDir strFileNameFolder
        '提取所有文件到此創(chuàng)建的文件夾
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(strFileNameFolder).CopyHere oApp.Namespace(strFileName).items
        '假如你只需要提取某一個(gè)文件,可以如下:
        'oApp.Namespace(strFileNameFolder).CopyHere oApp.Namespace(strFileName).items.Item("test.txt")
        MsgBox "文件已經(jīng)解壓到: " & strFileNameFolder
        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        '刪除臨時(shí)文件
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    End If
End Sub 
分享
文章分類
聯(lián)系我們
聯(lián)系人: 王先生
Email: 18449932@qq.com
QQ: 18449932
微博: officecn01
移動(dòng)訪問