Zip and Unzip Example-VBForums
Results 1 to 3 of 3

Thread: Zip and Unzip Example

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Aug 2011
    Location
    B.C., Canada
    Posts
    2,553

    Zip and Unzip Example

    I modified code i got from some website don't remember where

    made it easy to zip/unzip files/folder..

    add this to a module:

    vb Code:
    1. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    2.  
    3. Private ShellClass  As Shell32.Shell
    4. Private Filesource  As Shell32.Folder
    5. Private Filedest    As Shell32.Folder
    6. Private Folderitems As Shell32.Folderitems
    7.    
    8.    
    9. Public Sub ZipFile(File_Location As String, ZippedFile_Destination As String)
    10.  
    11. Create_New_Folder ZippedFile_Destination
    12.  
    13. If Right$(UCase$(ZippedFile_Destination), 4) <> ".ZIP" Then
    14.    ZippedFile_Destination = ZippedFile_Destination & ".ZIP"
    15. End If
    16.            
    17. If Not Create_Empty_Zip(ZippedFile_Destination) Then
    18.    Set_To_Nothing
    19.    Exit Sub
    20. End If
    21.        
    22.            
    23. Set ShellClass = New Shell32.Shell
    24. Set Filedest = ShellClass.NameSpace(ZippedFile_Destination)
    25.            
    26. Call Filedest.CopyHere(File_Location, 20)
    27.      
    28. Call Sleep(1000)
    29.      
    30. End Sub
    31.  
    32. Public Sub ZipFolder(Folder_Location As String, ZippedFolder_Destination As String)
    33.  
    34. Create_New_Folder ZippedFolder_Destination
    35.  
    36. If Right$(UCase$(ZippedFolder_Destination), 4) <> ".ZIP" Then
    37.    ZippedFolder_Destination = ZippedFolder_Destination & ".ZIP"
    38. End If
    39.            
    40. If Not Create_Empty_Zip(ZippedFolder_Destination) Then
    41.    Set_To_Nothing
    42.    Exit Sub
    43. End If
    44.        
    45. Set ShellClass = New Shell32.Shell
    46. Set Filesource = ShellClass.NameSpace(Folder_Location)
    47. Set Filedest = ShellClass.NameSpace(ZippedFolder_Destination)
    48. Set Folderitems = Filesource.Items
    49.            
    50. Call Filedest.CopyHere(Folderitems, 20)
    51.    
    52. Call Sleep(1000)
    53.        
    54. End Sub
    55.  
    56. Public Sub Unzip(ZipFile_Location As String, UnzipFiles_Destination As String)
    57.  
    58. Create_New_Folder UnzipFiles_Destination
    59.  
    60. If Right$(UCase$(ZipFile_Location), 4) <> ".ZIP" Then
    61.    ZipFile_Location = ZipFile_Location & ".ZIP"
    62. End If
    63.            
    64. Set ShellClass = New Shell32.Shell
    65. Set Filesource = ShellClass.NameSpace(ZipFile_Location)
    66. Set Filedest = ShellClass.NameSpace(UnzipFiles_Destination)
    67. Set Folderitems = Filesource.Items
    68.            
    69. Call Filedest.CopyHere(Folderitems, 20)
    70.      
    71. Call Sleep(1000)
    72.          
    73. End Sub
    74.  
    75. Private Function Create_Empty_Zip(sFileName As String, Optional sLocation As String) As Boolean
    76.  
    77.     Dim EmptyZip()  As Byte
    78.     Dim J           As Integer
    79.  
    80.     On Error GoTo EH
    81.     Create_Empty_Zip = False
    82.    
    83.     ReDim EmptyZip(1 To 22)
    84.  
    85.     EmptyZip(1) = 80
    86.     EmptyZip(2) = 75
    87.     EmptyZip(3) = 5
    88.     EmptyZip(4) = 6
    89.    
    90.     For J = 5 To UBound(EmptyZip)
    91.         EmptyZip(J) = 0
    92.     Next
    93.  
    94.     If sLocation = "" Then
    95.     Open sFileName For Binary Access Write As #1
    96.     Else
    97.     Open sFileName For Binary Access Write As #1
    98.     End If
    99.    
    100.     For J = LBound(EmptyZip) To UBound(EmptyZip)
    101.         Put #1, , EmptyZip(J)
    102.     Next
    103.    
    104.     Close #1
    105.  
    106.     Create_Empty_Zip = True
    107.  
    108. EH:
    109.    
    110.     If Err.Number <> 0 Then
    111.         MsgBox Err.Description, vbExclamation, "Error"
    112.     End If
    113.    
    114. End Function
    115.  
    116. Private Sub Set_To_Nothing()
    117.     Set ShellClass = Nothing
    118.     Set Filesource = Nothing
    119.     Set Filedest = Nothing
    120.     Set Folderitems = Nothing
    121. End Sub
    122.  
    123.  
    124. Private Function Create_New_Folder(str_FolderPath As String, Optional Ask_Privilege As Boolean, Optional MsgBox_OnOff As Boolean) As Boolean
    125. Dim SplitFolders() As String
    126. Dim Checking_CurrentFolder As String
    127. Dim i As Integer
    128.  
    129. On Error GoTo ErrCreatingFolder
    130.  
    131. If Dir(str_FolderPath, vbDirectory) = vbNullString Then
    132.    GoTo Split_Folders
    133.  
    134. Else
    135.  
    136.    Exit Function
    137.  
    138. End If
    139.  
    140.  
    141. Split_Folders:
    142. SplitFolders = Split(str_FolderPath, "\")
    143.  
    144. For i = 0 To UBound(SplitFolders)
    145.    Checking_CurrentFolder = Checking_CurrentFolder & SplitFolders(i)
    146.    
    147.    If Dir(Checking_CurrentFolder, vbDirectory) = vbNullString Then
    148.       MkDir (Checking_CurrentFolder)
    149.    End If
    150.    
    151.    Checking_CurrentFolder = Checking_CurrentFolder & "\"
    152.    
    153. Next
    154.  
    155. If MsgBox_OnOff = True Then
    156.    MsgBox "New folder " & Chr(34) & Left(Checking_CurrentFolder, Len(Checking_CurrentFolder) - 1) & " has been created!", vbExclamation, "New Folder Created"
    157. End If
    158.  
    159. Create_New_Folder = True
    160.  
    161. Exit Function
    162.  
    163. ErrCreatingFolder:
    164. Create_New_Folder = False
    165. If MsgBox_OnOff = True Then
    166.    MsgBox "Error Creating Folder"
    167. End If
    168. End Function

    and to zip a file write
    vb Code:
    1. ZipFile 'Zip a single File
    2. ZipFolder 'Zip a Folder
    3. Unzip 'Unzip all Files from Zip File


    or i will attach a user ocx if you wanna add to you object list

    modify as much as you want
    Attached Files Attached Files
    Last edited by Max187Boucher; Aug 6th, 2012 at 02:07 AM.

  2. #2
    New Member
    Join Date
    Aug 2010
    Posts
    14

    Re: Zip and Unzip Example

    I found this code and it's wonderful. But I'm having a problem with zipping. My source directory has 250 files and often the zip only copies most of them. It will get to 180 or 200 or even 210 but doesn't reliably do all 250.

    Is there a time constraint? A size limitation? A setting I need to change when creating the empty file?

    Please help! Thank you.

  3. #3
    Default Member Bonnie West's Avatar
    Join Date
    Jun 2012
    Location
    InIDE
    Posts
    3,142

    Re: Zip and Unzip Example

    Perhaps it's time to try other compression codes. There are plenty of them at PSC.
    On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
    Declare Sub CrashVB Lib "msvbvm60" (Optional DontPassMe As Any)

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width

Survey posted by VBForums.