Solved

Zip & Unzip files(All types of files)

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

Accepted Solution

by:
Ryan Chong earned 100 total points
Comment Utility
0
 
LVL 49

Expert Comment

by:Ryan Chong
Comment Utility
0
 
LVL 28

Expert Comment

by:iboutchkine
Comment Utility
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
Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

 
LVL 28

Expert Comment

by:iboutchkine
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
Comment from expert accepted as answer

Computer101
E-E Moderator
0

Featured Post

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

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 need to start windows update installation remotely or as a scheduled task you will find this very helpful.
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…
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…

771 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

Need Help in Real-Time?

Connect with top rated Experts

7 Experts available now in Live!

Get 1:1 Help Now