Solved

Zip & Unzip files(All types of files)

Posted on 2001-07-12
7
674 Views
Last Modified: 2008-03-04
i want to zip and unzip files using visual basic
0
Comment
Question by:yesh
7 Comments
 
LVL 51

Accepted Solution

by:
Ryan Chong earned 100 total points
ID: 6276424
0
 
LVL 51

Expert Comment

by:Ryan Chong
ID: 6276433
0
 
LVL 28

Expert Comment

by:iboutchkine
ID: 6276810
Try this

'frmZipping
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"
    Else
        Call RunWinZip(strSourceDir, strDestFile)
        CheckName = CheckNameToFind(strDestFile)
        HwndOfWinzip = FindHwndOfWinzip("WinZip - " & CheckName)
       
        Do Until ProcessIsReady = True
            GetPercentDone = GetPercentComplete(HwndOfWinzip)
            frmZipping.ProgressBar1.Value = GetPercentDone
            frmZipping.ProgressBar1.Refresh
            ProcessIsReady = CheckWinzipProcess
            DoEvents
        Loop
    End If
Exit Function

QuitZipProcess:
    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
    Else
        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
                DoEvents
            Else
                GetPercentComplete = CheckPercentComplete
                DoEvents
            End If
        Else
            GetPercentComplete = CheckPercentComplete
            DoEvents
        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
            DoEvents
        Else
            CheckWinzipProcess = True
            DoEvents
        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
        Else
            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


0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 28

Expert Comment

by:iboutchkine
ID: 6276815
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
0
 
LVL 20

Expert Comment

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

Expert Comment

by:DanRollins
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
0
 
LVL 1

Expert Comment

by:Computer101
ID: 7179107
Comment from expert accepted as answer

Computer101
E-E Moderator
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
using Access 8 83
Using "ScreenUpdating" 6 83
Search combo error "Data Type Mismatch in Criteria Expression" 2 80
Export Data to Different .csv Files 26 121
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…
The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
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…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

685 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