• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 694
  • Last Modified:

Zip & Unzip files(All types of files)

i want to zip and unzip files using visual basic
1 Solution
Try this

Private Sub Command1_Click()
    With Options
        .ActionToDo = Add
        .Compression = eXtra
        .FilesToAdd = AddHiddenSystem
        .Options = Recurse_Directories
        .IfFileAlreadyExists = AlwaysOverwrite
    End With
    Call AddFilesToZip(txtSourceDir, txtDestFile)
End Sub

'module - mdlAddToZip
Public SetToHide As Boolean

Private Enum CheckDirOrFile
    IsDirectory = 1
    IsFilename = 2
End Enum

Public Function AddFilesToZip(strSourceDir As String, strDestFile As String, Optional LocationOfWinZip As String) As String
    Dim ProcessIsReady As Boolean
    Dim CheckFile As Boolean
    Dim CheckName As String
    Dim HwndOfWinzip As Integer
    Dim GetPercentDone As Byte
    CheckFile = FileExists(strDestFile, IsFilename)
    With Options
        If CheckFile = True Then
            Select Case .IfFileAlreadyExists
                Case 0: GoTo QuitZipProcess    '(Default) NotOverwrite
                Case 1: Kill strDestFile       'AlwaysOverwrite
                Case 2: GoTo QuitZipProcess    'NotOverwrite
                Case Else: GoTo QuitZipProcess '(Default) NotOverwrite
            End Select
        End If
    End With
    CheckFile = FileExists(strSourceDir, IsDirectory)
    If CheckFile = False Then
        MsgBox "Deze directory bestaat niet"
        Call RunWinZip(strSourceDir, strDestFile)
        CheckName = CheckNameToFind(strDestFile)
        HwndOfWinzip = FindHwndOfWinzip("WinZip - " & CheckName)
        Do Until ProcessIsReady = True
            GetPercentDone = GetPercentComplete(HwndOfWinzip)
            frmZipping.ProgressBar1.Value = GetPercentDone
            ProcessIsReady = CheckWinzipProcess
    End If
Exit Function

    MsgBox "Het ZIP process is afgebroken"
End Function

Private Function RunWinZip(strSourceDir As String, strDestFile As String, Optional LocationOfWinZip As String, Optional Options As String) As Integer
    Dim CommandLine As String
    CommandLine = GetOptions
    If Trim(LocationOfWinZip) = "" Then
        Shell "C:\program Files\Winzip\Winzip32.exe" & CommandLine & strDestFile & " " & strSourceDir & "\*.*", vbHide
        Shell LocationOfWinZip & CommandLine & strDestFile & " " & strSourceDir & "\*.*", vbHide
    End If
End Function

Private Function FindHwndOfWinzip(strNameToFind As String) As Integer
    Dim i As Integer
    Dim FindHWND As Integer
    Call DoEnumWindows

    For i = 1 To InsertWindowInfo.ItemsInArray
        FindHWND = InStr(LCase(InsertWindowInfo.GetWindowName(i)), LCase(strNameToFind))
        If FindHWND <> 0 Then
            GetWinZipHwnd = InsertWindowInfo.GetHWND(i)
            Call EnumChildWindows(GetWinZipHwnd, AddressOf WndEnumChildProc, Nothing)
            FindHwndOfWinzip = GetProgressHwnd
        End If
    Next i
End Function

Private Function GetPercentComplete(HwndToTrack As Integer) As Byte
    Dim CheckPercentComplete As Byte
    CheckPercentComplete = SendMessage(GetProgressHwnd, PBM_GETPOS, 0, ByVal 0)
        If CheckPercentComplete > 20 Then
            If SetToHide = False Then
                Call MoveWindowToHidePos
                SetToHide = True
                GetPercentComplete = CheckPercentComplete
                GetPercentComplete = CheckPercentComplete
            End If
            GetPercentComplete = CheckPercentComplete
        End If
End Function

Private Sub MoveWindowToHidePos()
    Dim GetResX As Integer
    Dim GetResY As Integer

    GetResX = Screen.Width \ Screen.TwipsPerPixelX
    GetResY = Screen.Height \ Screen.TwipsPerPixelY

    Call MoveWindow(GetWinZipHwnd, GetResX + 1000, GetResY + 1000, 0, 0, 1)
    Call ShowWindow(GetWinZipHwnd, SW_SHOW)

End Sub

Private Function GetOptions() As String
    Dim MakeCmdLine As String
    With Options
        Select Case .ActionToDo
            Case 0, 1: MakeCmdLine = "-a"              'Add / -a
            Case 2: MakeCmdLine = "-f"                 'Freshen / -f
            Case 3: MakeCmdLine = "-u"                 'Update / u
            Case 4: MakeCmdLine = "-m"                 'Move / -m
            Case Else: MakeCmdLine = "-a"              'Add / -a
        End Select
        Select Case .Compression
            Case 0: MakeCmdLine = MakeCmdLine & " -en" '(Default) Normal / -en
            Case 1: MakeCmdLine = MakeCmdLine & " -ex" 'Extra / -ex
            Case 2: MakeCmdLine = MakeCmdLine & " -en" 'Normal / -en
            Case 3: MakeCmdLine = MakeCmdLine & " -ef" 'Fast / -ef
            Case 4: MakeCmdLine = MakeCmdLine & " -es" 'Super fast / -es
            Case 5: MakeCmdLine = MakeCmdLine & " -e0" 'No compression / -e0
            Case Else: MakeCmdLine = MakeCmdLine & " -en" '(Default) Normal / -en
        End Select
        Select Case .FilesToAdd
            Case 0, 1: MakeCmdLine = MakeCmdLine & " -hs" 'AddHiddenSystem / -hs
            Case Else: MakeCmdLine = MakeCmdLine & " -hs" '(Default) AddHiddenSystem / -hs
        End Select
        Select Case .Options
            Case 0: MakeCmdLine = MakeCmdLine & " -r"  '(Default) Recurse_Directories / -r
            Case 1: MakeCmdLine = MakeCmdLine & " -r"  'Recurse_Directories / -r
            Case 2: MakeCmdLine = MakeCmdLine & " -p"  'Save_Extra_Directory_Info / -p
            Case Else: MakeCmdLine = MakeCmdLine & " -r" '(Default) Recurse_Directories / -r
        End Select
        Select Case .PassWord
            Case 0:                                    'Nothing - No protection
            Case 1: MakeCmdLine = MakeCmdLine & " -s"  'Password protection / -s
            Case Else:                                 'Nothing - No protection
        End Select
    End With
    GetOptions = " " & MakeCmdLine & " "
End Function

Private Function CheckWinzipProcess() As Boolean
    Dim strNameOfWinzip As String
    strNameOfWinzip = GetWindowName(GetWinZipHwnd)
        If Trim(strNameOfWinzip) <> "" Then
            CheckWinzipProcess = False
            CheckWinzipProcess = True
        End If
End Function

Private Function FileExists(Filename, WhatToCheck As CheckDirOrFile) As Boolean
    Select Case WhatToCheck
        Case 1:
                If Right(Filename, 1) <> "\" Then
                    Filename = Filename & "\"
                    FileExists = (Dir(Filename) <> "")
                End If
        Case 2:
                FileExists = (Dir(Filename) <> "")
    End Select
End Function

Private Function CheckNameToFind(NameToCheck As String) As String
    If Mid(NameToCheck, 2, 2) = ":\" Then
        CheckNameToFind = Trim(Mid(NameToCheck, 4))
    End If
End Function

'module - mdlEnumWindows

Private Declare Function EnumWindows Lib "User32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "User32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Declare Function EnumChildWindows Lib "User32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Any) As Long
    Public GetProgressHwnd As Long
    Public GetWinZipHwnd As Long
    Public InsertWindowInfo As GetWindowInfo
        Private Type GetWindowInfo
            GetHWND(1 To 1000) As Integer
            GetWindowName(1 To 1000) As String
            ItemsInArray As Integer
        End Type

Public Sub DoEnumWindows()
    Call EnumWindows(AddressOf EnumWindowProc, &H0)
End Sub

Private Function EnumWindowProc(ByVal hwnd As Long, ToListbox As ListBox) As Long
    Dim strWindowName    As String
    Dim strClassName     As String
    strWindowName = GetWindowName(hwnd)
        With InsertWindowInfo
            .ItemsInArray = .ItemsInArray + 1
            .GetHWND(.ItemsInArray) = CInt(hwnd)
            .GetWindowName(.ItemsInArray) = strWindowName
        End With
    EnumWindowProc = 1 'Zorgt ervoor dat Enumwindows door blijft gaan totdat er geen HWND's meer zijn
End Function

Public Function GetWindowName(Handle As Long) As String
    Dim intWindowLenght  As Integer
    Dim strWindowName    As String
        intWindowLenght = GetWindowTextLength(Handle) + 1
        strWindowName = Space$(intWindowLenght)
        GetWindowText Handle, strWindowName, intWindowLenght ' API function call
        strWindowName = Mid(strWindowName, 1, Len(strWindowName) - 1)
    GetWindowName = strWindowName
End Function
Public Function WndEnumChildProc(ByVal hwnd As Long) As Long
    Dim bRet As Long
    Dim myStr As String * 50
    Dim FindClass As Integer
    bRet = GetClassName(hwnd, myStr, 50)
    FindClass = InStr(LCase(myStr), "msctls_progress32")
        If FindClass <> 0 Then
            GetProgressHwnd = hwnd
            WndEnumChildProc = 1
        End If
End Function

'module - mdlWindowProp

Public Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, wParam As Any, lParam As Any) As Long
Public Declare Function MoveWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Public Declare Function ShowWindow Lib "User32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

'Hoort bij ShowWindow
Public Const SW_HIDE = 0 'Hide the window.
Public Const SW_MAXIMIZE = 3 'Maximize the window.
Public Const SW_MINIMIZE = 6 'Minimize the window.
Public Const SW_RESTORE = 9 'Restore the window (not maximized nor minimized).
Public Const SW_SHOW = 5 'Show the window.
Public Const SW_SHOWMAXIMIZED = 3 'Show the window maximized.
Public Const SW_SHOWMINIMIZED = 2 'Show the window minimized.
Public Const SW_SHOWMINNOACTIVE = 7 'Show the window minimized but do not activate it.
Public Const SW_SHOWNA = 8 'Show the window in its current state but do not activate it.
Public Const SW_SHOWNOACTIVATE = 4 'Show the window in its most recent size and position but do not activate it.
Public Const SW_SHOWNORMAL = 1 'Show the window and activate it (as usual).

'Hoort bij SendMessage
Public Const PBM_STEPIT = 1029
Public Const WM_USER = &H400
Public Const PBM_GETPOS = (WM_USER + 8)

'module - mdlZipOptions

    Public Options As ZipOptions
        Public Type ZipOptions
            ActionToDo As ActionZIP
            Options As OptionsZIP
            Compression As CompressionZIP
            PassWord As String
            FilesToAdd As FilesToAddZIP
            IfFileAlreadyExists As IfFileExists
        End Type
    Public Enum ActionZIP
        Add = 1                        'Add to archive
        Freshen = 2                    'Freshen archive
        Update = 3                     'Update archive
        Move = 4                       'Move to archive
    End Enum

    Public Enum OptionsZIP
        Recurse_Directories = 1        'Recurse Directories
        Save_Extra_Directory_Info = 2  'Save Extra Directory Info
    End Enum

    Public Enum CompressionZIP
        eXtra = 1                      'Extra
        Normal = 2                     'Normal
        Fast = 3                       'Fast
        Super_Fast = 4                 'Super fast
        No_Compression = 5             'No compression
    End Enum

    Public Enum PassWordZIP
        PassWord = 1                   'Password protection.
    End Enum

    Public Enum FilesToAddZIP
        AddHiddenSystem = 1            'Add also hidden and system files to archive
        DoNotAddHiddenSystem = 1
    End Enum

    Public Enum IfFileExists
        AlwaysOverwrite = 1
        NotOverwrite = 2
    End Enum

Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

Another example

c = Shell("d:\temp\pkunzip.exe d:\temp\t001015.zip d:\temp", vbHide)

'========another way========
' Inputs:'Example:
'source = app.path & "source.exe"
'target = app.path & "target.zip"
'zip = true (compress)
'zip = false(uncompress)

Function winZipit(ByVal source As String, ByVal target As String, ByVal zip As Boolean)
    zipIT = App.Path & "winzip32 -a"
    unzipIT = App.Path & "winzip32 -e "

    If zip = True Then
        Shell (zipIT & target & source)
    Else: Shell (unzipIT & target & source)
    End If
End Function
As ryancys gave you links to the vbaccelerator methods using teh zip and unzip dll's are the best way to go
Hi yesh,
It appears that you have forgotten this question. I will ask Community Support to close it unless you finalize it within 7 days. I will ask a Community Support Moderator to:

    Accept ryancys's comment(s) as an answer.

yesh, if you think your question was not answered at all or if you need help, just post a new comment here; Community Support will help you.  DO NOT accept this comment as an answer.

EXPERTS: If you disagree with that recommendation, please post an explanatory comment.
DanRollins -- EE database cleanup volunteer
Comment from expert accepted as answer

E-E Moderator
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Get your problem seen by more experts

Be seen. Boost your question’s priority for more expert views and faster solutions

Tackle projects and never again get stuck behind a technical roadblock.
Join Now