Zip & Unzip files(All types of files)

Posted on 2001-07-12
Last Modified: 2008-03-04
i want to zip and unzip files using visual basic
Question by:yesh
LVL 50

Accepted Solution

Ryan Chong earned 100 total points
ID: 6276424
LVL 50

Expert Comment

by:Ryan Chong
ID: 6276433
LVL 28

Expert Comment

ID: 6276810
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

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

LVL 28

Expert Comment

ID: 6276815
Another example

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

'========another way========
' Inputs:'Example:
'source = app.path & "source.exe"
'target = app.path & ""
'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
LVL 20

Expert Comment

ID: 6277082
As ryancys gave you links to the vbaccelerator methods using teh zip and unzip dll's are the best way to go
LVL 49

Expert Comment

ID: 7153059
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

Expert Comment

ID: 7179107
Comment from expert accepted as answer

E-E Moderator

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Best way to parse out a json string in VB6? 10 217
using web browser with BING 40 131
VB6 - Convert HH:MM into Decimal 8 62
Spell Check in VB6 13 126
There are many ways to remove duplicate entries in an SQL or Access database. Most make you temporarily insert an ID field, make a temp table and copy data back and forth, and/or are slow. Here is an easy way in VB6 using ADO to remove duplicate row…
If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

808 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question