인터넷 서핑하다가 발견한 소스입니다.

VBA로 zip파일의 압축을 풀일이 얼마나 있을지는 모르겠지만..

일단 알아두면 언젠간 필요할 일이 있을 것 같네요.. ^^


출처 : http://www.rondebruin.nl/win/s7/win002.htm


Example 1 _ *.zip파일 압축 풀기..

With this example you can browse to the zip file. After you select the zip file the macro will create a new folder in your DefaultFilePath and unzip the Zip file in that folder. You can run the code without any changes.

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

    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=False)
    If Fname = False Then
        'Do nothing
    Else
        'Root folder for the new folder.
        'You can also use DefPath = "C:\Users\Ron\test\"
        DefPath = Application.DefaultFilePath
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

        'Create the folder name
        strDate = Format(Now, " dd-mm-yy h-mm-ss")
        FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"

        'Make the normal folder in DefPath
        MkDir FileNameFolder

        'Extract the files into the newly created folder
        Set oApp = CreateObject("Shell.Application")

        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items

        'If you want to extract only one file you can use this:
        'oApp.Namespace(FileNameFolder).CopyHere _
         'oApp.Namespace(Fname).items.Item("test.txt")

        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 





참고로..

zip파일을 만드는 코드는 아래와 같다.


출처 : http://www.rondebruin.nl/win/s7/win001.htm


 

Code used by every example macro on this page

Every macro use the sub NewZip and the first example also use both functions.

Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub


Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function


Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
    Split97 = Evaluate("{""" & _
                       Application.Substitute(sStr, sdelim, """,""") & """}")
End Function

 

Examples

There are five examples on this page that you can copy in a normal module of your workbook.
Please read the information good above before you start testing the code below.

Browse to the folder you want and select the file or files

Sub Zip_File_Or_Files()
    Dim strDate As String, DefPath As String, sFName As String
    Dim oApp As Object, iCtr As Long, I As Integer
    Dim FName, vArr, FileNameZip

    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"

    'Browse to the file(s), use the Ctrl key to select more files
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                    MultiSelect:=True, Title:="Select the files you want to zip")
    If IsArray(FName) = False Then
        'do nothing
    Else
        'Create empty Zip File
        NewZip (FileNameZip)
        Set oApp = CreateObject("Shell.Application")
        I = 0
        For iCtr = LBound(FName) To UBound(FName)
            vArr = Split97(FName(iCtr), "\")
            sFName = vArr(UBound(vArr))
            If bIsBookOpen(sFName) Then
                MsgBox "You can't zip a file that is open!" & vbLf & _
                       "Please close it and try again: " & FName(iCtr)
            Else
                'Copy the file to the compressed folder
                I = I + 1
                oApp.Namespace(FileNameZip).CopyHere FName(iCtr)

                'Keep script waiting until Compressing is done
                On Error Resume Next
                Do Until oApp.Namespace(FileNameZip).items.Count = I
                    Application.Wait (Now + TimeValue("0:00:01"))
                Loop
                On Error GoTo 0
            End If
        Next iCtr

        MsgBox "You find the zipfile here: " & FileNameZip
    End If
End Sub

profile