Zip/Unzip utility (1 Viewer)

[NauticalGent]

How can it be that something that is built into Windows is so complicated to incorporate into an Access App? Daniel Pineault has a nice PowerShell wrapper that was working great until my IT dept decided that calling PS commands from an MS Office App was bad JuJu.

If anyone has something handy that is comprehensive, I would be grateful if you shared it!

 

[strive4peace]

hi John @NauticalGent

sorry to hear you're losing power due to bad decisions that negatively affect productivity -- a way around that would be for Access to make a batch file you can run ... surely that must be possible. Then Access could launch it ~

example of going through a zip file and unzipping it to a folder:

Sub Unzip(varZipFile,varTargetFolder)
'Purpose  : Unzip file using default Win XP zip program.
'DateTime : 12/12/2007 12:55
'Author   : Bill Mosca
    Dim oApp
    Dim varItem
    Dim fs,fdr

    'Check that folder ends with "\"
    If Right(varTargetFolder,1) <>  "\" Then
        varTargetFolder = varTargetFolder &  "\"
    End If

    Set oApp = CreateObject( "Shell.Application")
    'Set fs = WScript.CreateObject("Scripting.FileSystemObject")
    Set fs = CreateObject( "Scripting.FileSystemObject")

    'Kill file if any exists.
    For Each varItem In oApp.Namespace(varZipFile).items
        If fs.FileExists(varTargetFolder & varItem.Name) = True Then
            fs.DeleteFile varTargetFolder & varItem.Name,True
        End If
    Next

    'Copy the files in the newly created folder
    oApp.Namespace(varTargetFolder).CopyHere oApp.Namespace
(varZipFile).items

    'Delete temp folder if it exists.
    On Error Resume Next
    Set fdr = fs.GetSpecialFolder(TemporaryFolder)
    fs.DeleteFolder fdr.Path &  "\Temporary Directory*",True

    Set fdr = Nothing
    Set fs = Nothing
    Set oApp = Nothing

End Sub

' Colored with free Color Code add-in for Access (with source code) posted on MsAccessGurus

Color Code

add color tags to code for posting on web pages and forums, blue keywords, green comments, VBA, BBCode, HTML

msaccessgurus.com

Here is alternate code to unzip, written by Ron de Bruin, who's a whiz with Excel and VBA

Home | Ron de Bruin Excel Automation

Welcome to https://www.rondebruin.nl

www.rondebruin.nl

Here's Ron's code to zip:

Home | Ron de Bruin Excel Automation

Welcome to https://www.rondebruin.nl

www.rondebruin.nl

 

[strive4peace]

@NauticalGent adding on, re PS commends

here is code that you can pattern after to create a batch file with a message:

Function CreateBatchFile(sMessage As String) As String
'160711 strive4peace
'this code creates a batch file with a message in the current database directory.
'return path and filename if successfully written

   On Error GoTo Proc_Err
   CreateBatchFile =  ""

   Dim sPathFile As String _
      ,iFileNumber As Integer

   sPathFile = CurrentProject.Path &  "\SayMsg.Bat"

   'delete the file that is already there
   If Len(Dir(sPathFile)) > 0 Then
      Kill sPathFile
      DoEvents
   End If

   'get a handle
   iFileNumber = FreeFile

   'close file handle if it is open
   'ignore any error from trying to close it if it is not
   On Error Resume Next
   Close #iFileNumber
   On Error GoTo Proc_Err

   'open file for output
   Open sPathFile For Output As #iFileNumber

   'write something
   Print #iFileNumber, "@ECHO ON"
   Print #iFileNumber, "@ECHO " & sMessage
   Print #iFileNumber, "@Pause"

   CreateBatchFile = sPathFile
   'MsgBox "Done Creating " & sPathFile, , "Done"

Proc_Exit:
   On Error Resume Next
   'close the file
   Close #iFileNumber

   Exit Function

'ERROR HANDLER
Proc_Err:
   MsgBox Err.Description _
     ,, "ERROR " & Err.Number _
     &  "   CreateBatchFile"

   Resume Proc_Exit

   'if you want to single-step code to find error, CTRL-Break at MsgBox
   'then set this to be the next statement
   Resume
End Function 

code to run it

Sub runCreateBatchFile()
'160711 strive4peace
'run a batch file

   On Error GoTo Proc_Err
   Dim sMessage As String _
      ,sPathFile As String _
      ,sCommand As String

   sMessage =  "This is a test"

   sPathFile = CreateBatchFile(sMessage)

   If Len(sPathFile) > 0 Then
      'to run without the user seeing what is going on :
'      Environ$("COMSPEC") is pathfile to cmd.exe
'      sCommand = Environ$("COMSPEC") & " /c " & sPathFile ' & " &&pause"
      'run and pause until user presses a key
      sCommand = sPathFile
      Shell sCommand,vbNormalFocus
   End If

Proc_Exit:
   On Error Resume Next
   Exit Sub

'ERROR HANDLER
Proc_Err:
   MsgBox Err.Description _
     ,, "ERROR " & Err.Number _
     &  "   runCreateBatchFile"

   Resume Proc_Exit

   'if you want to single-step code to find error, CTRL-Break at MsgBox
   'then set this to be the next statement
   Resume
End Sub

 

[sxschech]

There is also similar code at

VBA - Create ZIP-Archive with the Shell32-Library

Article and sample code on creating a ZIP-Archive, adding files and unzipping archives with VBA and the Shell32-Library.

codekabinett.com

Then modified one of the functions to do a test if a file is in a zip

Public Function IsInZip(ByVal zipArchivePath As String, ByVal FileName As String)
'Modified DeleteFileWithInvokeVerb to test whether a file is in the zip
'Use per suggestion from theDBGuy to check that the file exists
'https://codekabinett.com/rdumps.php?Lang=2&targetDoc=create-zip-archive-vba-shell32
'20190417
    Dim sh As Object
    Dim fTarget As Object
    Dim iSource As Object
    Dim targetItem As Object
    Dim i As Long
    
    Set sh = CreateObject("Shell.Application")
    Set fTarget = sh.Namespace((zipArchivePath))
    
    For i = 0 To fTarget.Items.Count - 1
        If fTarget.Items.Item((i)).name = FileName Then
            Set targetItem = fTarget.Items.Item((i))
            Exit For
        End If
    Next i
 
    If Not targetItem Is Nothing Then
        IsInZip = True
    Else
        IsInZip = False
    End If
 
End Function