Monday 5 August 2013

VBA Modules: modZip v8.04

Read this for full information on these modules

This particular module is very useful, uses the excellent 7zip command line application to automatically zip or unzip any type of file.  It will work with URL source/targets, but always more reliable with UNC.
The Zip7sub macro will "install" 7zip automatically if you save 7za.exe somewhere publicly accessible on your network and specify the location in the code below.  Note that the "iShare" UNC address I've used is not accessible to the public, so you just have to replace the location with one you can access.   It can of course also be any accessible location on your own machine, e.g. your Desktop or Documents or Downloads folder.

This module makes use of ShellAndWait by Chip Pearson and modSpecialFolders -- standard function code from the Microsoft support site.  Code from both is included within this module.

v8 adds z7_Force_Connection -- adapted from the xlSharePoint module.  Highly recommended to run this before zipping to SharePoint locations.

If you're running this from Access or Outlook, it'll work fine, but you should enable Excel Object Library via Tools > References to prevent Debug > Compile errors with a couple of Excel Application commands.

As it says below, it should still work in XP, but I've not tested it since I updated the code for Windows 7.

'v8.04 2014-01-10 14:27

' Code is provided without warranty and can be stolen and amended as required.
'   Tom Parish
'   DGF Help Contact: see BPMHelpContact module


' modZip
'   Various zipping functions.  Uses 7zip Command Line Utility (7za.exe)
'   7zip is free for personal or business use
'   Module self-installs (copies) 7zip from shared drive or SharePoint
'   location(s) to [C:\Users\[userID]\Documents]\[zSubFolder]\[z7pth]\
'   Can easily be adapted to use WinZip or any command line utility,
'   but pay careful attention to app-specific command line syntax.
'   Syntax to zip file(s):
'       Zip7Sub [FilesPathFn], [ArchivePathFn], True
'   Also see:
'       Sub syntax_to_zip_one_file()

' Additional modules required:
'   None
'   Code included from other modules:
'      [modSpecialFolders]
'      [xlShellAndWait]

' Additional References required:
'   Microsoft Excel Object Library (if not running from Excel)

' External applications required:
'   None

'v8.04 2014-01-10 14:27 - Z7_Force_Connection - bugfix for zips (remove "" from ends)
'v8.03 2014-01-09 18:13 - Z7_CloseExplorerWindow - bugfix to prevent errors with Internet Explorer shell windows
'v8.02 2014-01-09 17:10 - Z7_CloseExplorerWindow - bugfix to prevent blank folder name
'v8.01 2014-01-09 15:46 - Z7_Force_Connection - added bExplorerKill failsafe option to kill all Explorer windows (prevents leaving countless processes open - although rarely triggered)
'v8.00 2014-01-10 10:28 - Z7_Force_Connection - checks/forces connection (to SharePoint) adapted from xlSharePoint v5.03
'   v7.01   syntax_to_zip_one_file: zips .rwz file first (Outlook Rules Wizard)
'   v7.01   syntax_to_zip_one_file: also zips .docx files
'   v7.00   ZIP_EXE_pthfn: rebuild, uses secondary/tertiary install locations
'   v6.00   included code from xlShellAndWait and modSpecialFolders
'   v5.03   syntax_to_zip_one_file: improved validity check in non-Excel apps
'   v5.02   syntax_to_zip_one_file: msgbox added
'   v5.01   ZIP_EXE_copy: added z7exn
'   v5.00a  annotations only
'   v5.00   WINDOWS 7 ONLY: moved to C:\Users\All Users\BPM Tools\
'           zlmax set to 2, now only refers to iShare sources (UNC then URL)
'   v4.02   syntax_to_zip_one_file: now sources from GBMNCWSA050
'   v4.01   bugfix: Application.Statusbar in non-Excel applications
'           bugfix: xlShellAndWait is only possible in Excel
'   v4.00   Zip7Sub: added zKillFirst and zRecurse options
'           ZIP_EXE_copy: process massively improved
'           annotations improved
'   v3.08   bugfix

Option Explicit


'zlmax = possible source locations in scope, MAX 2 in code  v5.00
    Private Const zlmax As Byte = 2  'v5.00
'users must have access to shared drive and SharePoint UNC/URL locations (read-only)
'NB: SharePoint cannot host exe files, so remove file extension, ".exe" will be renamed during FileCopy
    Private Const z7e1 As String = "\\\sites\DGFUK\BPMpublic\Resources\"                  'v5.00
    Private Const z7e2 As String = ""             'v5.00
'subfolders in local [C:\Users]\All Users\ folder to create for copying 7za.exe (can be "")
    Private Const zSubFolder As String = "BPM Tools"  'use backslash to specify 2 deep e.g. "SubFolder1\SubFolder2"
    Private Const z7pth As String = "7z"        'subfolder for 7zip                                     'v5.01
'possible 7zip executable filenames
    Private Const z7exe As String = "7za.exe"   'any location where .exe is permitted                   'v5.01
    Private Const z7ext As String = "7za.ext"   'any location where .exe forbidden                      'v5.01
    Private Const z7exn As String = "7za"       'any location where .exe forbidden, without extension   'v5.01

    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)
    Private Const zSleepTime As Long = 10000  'v5.03, time in ms, i.e. 10000 = 10s


'   Code from xlShellAndWait module:

Option Compare Text

' modShellAndWait
' By Chip Pearson,,
' This page on the web site:
' 9-September-2008
' This module contains code for the ShellAndWait function that will Shell to a process
' and wait for that process to end before returning to the caller.
Private Declare Function WaitForSingleObject Lib "kernel32" ( _
    ByVal hHandle As Long, _
    ByVal dwMilliSeconds As Long) As Long

Private Declare Function OpenProcess Lib "kernel32.dll" ( _
    ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long) As Long

Private Const SYNCHRONIZE = &H100000

Private Enum ShellAndWaitResult
    Success = 0
    Failure = 1
    TimeOut = 2
    InvalidParameter = 3
    SysWaitAbandoned = 4
    UserWaitAbandoned = 5
    UserBreak = 6
End Enum

Private Enum ActionOnBreak
    IgnoreBreak = 0
    AbandonWait = 1
    PromptUser = 2
End Enum

Private Const STATUS_ABANDONED_WAIT_0 As Long = &H80
Private Const STATUS_WAIT_0 As Long = &H0
Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0 + 0)
Private Const WAIT_TIMEOUT As Long = 258&
Private Const WAIT_FAILED As Long = &HFFFFFFFF
Private Const WAIT_INFINITE = -1&


'   Code from modSpecialFolders module:

Private Declare Function SHGetSpecialFolderLocation _
                         Lib "shell32" (ByVal hwnd As Long, _
                                        ByVal nFolder As Long, ppidl As Long) As Long

Private Declare Function SHGetPathFromIDList _
                         Lib "shell32" Alias "SHGetPathFromIDListA" _
                             (ByVal Pidl As Long, ByVal pszPath As String) As Long

Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)

Private Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)
Private Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs
Private Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel
Private Const CSIDL_PRINTERS = &H4 'My Computer\Printers
Private Const CSIDL_PERSONAL = &H5 'My Documents
Private Const CSIDL_FAVORITES = &H6 '<user name>\Favorites
Private Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup
Private Const CSIDL_RECENT = &H8 '<user name>\Recent
Private Const CSIDL_SENDTO = &H9 '<user name>\SendTo
Private Const CSIDL_BITBUCKET = &HA '<desktop>\Recycle Bin
Private Const CSIDL_STARTMENU = &HB '<user name>\Start Menu
Private Const CSIDL_DESKTOPDIRECTORY = &H10 '<user name>\Desktop
Private Const CSIDL_DRIVES = &H11 'My Computer
Private Const CSIDL_NETWORK = &H12 'Network Neighborhood
Private Const CSIDL_NETHOOD = &H13 '<user name>\nethood
Private Const CSIDL_FONTS = &H14 'Windows\fonts
Private Const CSIDL_TEMPLATES = &H15
Private Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu
Private Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs
Private Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup
Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop
Private Const CSIDL_APPDATA = &H1A '<user name>\Application Data
Private Const CSIDL_PRINTHOOD = &H1B '<user name>\PrintHood
Private Const CSIDL_LOCAL_APPDATA = &H1C '<user name>\Local Settings\Application Data (non roaming)
Private Const CSIDL_ALTSTARTUP = &H1D 'non localized startup
Private Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup
Private Const CSIDL_COOKIES = &H21
Private Const CSIDL_HISTORY = &H22
Private Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data
Private Const CSIDL_WINDOWS = &H24 'Windows Directory
Private Const CSIDL_SYSTEM = &H25 'System Directory
Private Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files
Private Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures
Private Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC
Private Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC
Private Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common
Private Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC
Private Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates
Private Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents
Private Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools
Private Const CSIDL_ADMINTOOLS = &H30 '<user name>\Start Menu\Programs\Administrative Tools
Private Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections
Private Const MAX_PATH = 260
Private Const NOERROR = 0

Private Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String

strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
    lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
    If lngFolderFound Then
        SpecFolder = Left$(strPath, _
                           InStr(1, strPath, vbNullChar) - 1)
    End If
End If
CoTaskMemFree lngPidl
End Function


Private Function ShellAndWait(ShellCommand As String, _
                    TimeOutMs As Long, _
                    ShellWindowState As VbAppWinStyle, _
                    BreakKey As ActionOnBreak) As ShellAndWaitResult
' ShellAndWait
' This function calls Shell and passes to it the command text in ShellCommand. The function
' then waits for TimeOutMs (in milliseconds) to expire.
'   Parameters:
'       ShellCommand
'           is the command text to pass to the Shell function.
'       TimeOutMs
'           is the number of milliseconds to wait for the shell'd program to wait. If the
'           shell'd program terminates before TimeOutMs has expired, the function returns
'           ShellAndWaitResult.Success = 0. If TimeOutMs expires before the shell'd program
'           terminates, the return value is ShellAndWaitResult.TimeOut = 2.
'       ShellWindowState
'           is an item in VbAppWinStyle specifying the window state for the shell'd program.
'       BreakKey
'           is an item in ActionOnBreak indicating how to handle the application's cancel key
'           (Ctrl Break). If BreakKey is ActionOnBreak.AbandonWait and the user cancels, the
'           wait is abandoned and the result is ShellAndWaitResult.UserWaitAbandoned = 5.
'           If BreakKey is ActionOnBreak.IgnoreBreak, the cancel key is ignored. If
'           BreakKey is ActionOnBreak.PromptUser, the user is given a ?Continue? message. If the
'           user selects "do not continue", the function returns ShellAndWaitResult.UserBreak = 6.
'           If the user selects "continue", the wait is continued.
'   Return values:
'            ShellAndWaitResult.Success = 0
'               indicates the the process completed successfully.
'            ShellAndWaitResult.Failure = 1
'               indicates that the Wait operation failed due to a Windows error.
'            ShellAndWaitResult.TimeOut = 2
'               indicates that the TimeOutMs interval timed out the Wait.
'            ShellAndWaitResult.InvalidParameter = 3
'               indicates that an invalid value was passed to the procedure.
'            ShellAndWaitResult.SysWaitAbandoned = 4
'               indicates that the system abandoned the wait.
'            ShellAndWaitResult.UserWaitAbandoned = 5
'               indicates that the user abandoned the wait via the cancel key (Ctrl+Break).
'               This happens only if BreakKey is set to ActionOnBreak.AbandonWait.
'            ShellAndWaitResult.UserBreak = 6
'               indicates that the user broke out of the wait after being prompted with
'               a ?Continue message. This happens only if BreakKey is set to
'               ActionOnBreak.PromptUser.


Dim TaskID As Long
Dim ProcHandle As Long
Dim WaitRes As Long
Dim Ms As Long
Dim MsgRes As VbMsgBoxResult
Dim SaveCancelKey As XlEnableCancelKey  'NB: only works in Excel
Dim ElapsedTime As Long
Dim Quit As Boolean
Const ERR_BREAK_KEY = 18

If Trim(ShellCommand) = vbNullString Then
    ShellAndWait = ShellAndWaitResult.InvalidParameter
    Exit Function
End If

If TimeOutMs < 0 Then
    ShellAndWait = ShellAndWaitResult.InvalidParameter
    Exit Function
ElseIf TimeOutMs = 0 Then
    Ms = TimeOutMs
End If

Select Case BreakKey
    Case AbandonWait, IgnoreBreak, PromptUser
        ' valid
    Case Else
        ShellAndWait = ShellAndWaitResult.InvalidParameter
        Exit Function
End Select

Select Case ShellWindowState
    Case vbHide, vbMaximizedFocus, vbMinimizedFocus, vbMinimizedNoFocus, vbNormalFocus, vbNormalNoFocus
        ' valid
    Case Else
        ShellAndWait = ShellAndWaitResult.InvalidParameter
        Exit Function
End Select

On Error Resume Next
TaskID = Shell(ShellCommand, ShellWindowState)
If (Err.Number <> 0) Or (TaskID = 0) Then
    ShellAndWait = ShellAndWaitResult.Failure
    Exit Function
End If

ProcHandle = OpenProcess(SYNCHRONIZE, False, TaskID)
If ProcHandle = 0 Then
    ShellAndWait = ShellAndWaitResult.Failure
    Exit Function
End If

On Error GoTo ErrH:
SaveCancelKey = Application.EnableCancelKey
Application.EnableCancelKey = xlErrorHandler
WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)
Do Until WaitRes = WAIT_OBJECT_0
    Select Case WaitRes
            ' Windows abandoned the wait
            ShellAndWait = ShellAndWaitResult.SysWaitAbandoned
            Exit Do
        Case WAIT_OBJECT_0
            ' Successful completion
            ShellAndWait = ShellAndWaitResult.Success
            Exit Do
        Case WAIT_FAILED
            ' attach failed
            ShellAndWait = ShellAndWaitResult.Success
            Exit Do
        Case WAIT_TIMEOUT
            ' Wait timed out. Here, this time out is on DEFAULT_POLL_INTERVAL.
            ' See if ElapsedTime is greater than the user specified wait
            ' time out. If we have exceed that, get out with a TimeOut status.
            ' Otherwise, reissue as wait and continue.
            ElapsedTime = ElapsedTime + DEFAULT_POLL_INTERVAL
            If Ms > 0 Then
                ' user specified timeout
                If ElapsedTime > Ms Then
                    ShellAndWait = ShellAndWaitResult.TimeOut
                    Exit Do
                    ' user defined timeout has not expired.
                End If
                ' infinite wait -- do nothing
            End If
            ' reissue the Wait on ProcHandle
            WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)
        Case Else
            ' unknown result, assume failure
            ShellAndWait = ShellAndWaitResult.Failure
            Quit = True
    End Select

CloseHandle ProcHandle
Application.EnableCancelKey = SaveCancelKey
Exit Function

Debug.Print "ErrH: Cancel: " & Application.EnableCancelKey
If Err.Number = ERR_BREAK_KEY Then
    If BreakKey = ActionOnBreak.AbandonWait Then
        CloseHandle ProcHandle
        ShellAndWait = ShellAndWaitResult.UserWaitAbandoned
        Application.EnableCancelKey = SaveCancelKey
        Exit Function
    ElseIf BreakKey = ActionOnBreak.IgnoreBreak Then
    ElseIf BreakKey = ActionOnBreak.PromptUser Then
        MsgRes = MsgBox("User Process Break." & vbCrLf & _
            "Continue to wait?", vbYesNo)
        If MsgRes = vbNo Then
            CloseHandle ProcHandle
            ShellAndWait = ShellAndWaitResult.UserBreak
            Application.EnableCancelKey = SaveCancelKey
            Resume Next
        End If
        'Debug.Print "Unknown value of 'BreakKey': " & CStr(BreakKey)
        CloseHandle ProcHandle
        Application.EnableCancelKey = SaveCancelKey
        ShellAndWait = ShellAndWaitResult.Failure
    End If
    ' some other error. assume failure
    CloseHandle ProcHandle
    ShellAndWait = ShellAndWaitResult.Failure
End If

Application.EnableCancelKey = SaveCancelKey

End Function


Function Zip7Sub(ByVal zPathFiles As String, ByVal zArchive As String _
    , ByVal ZIP_IT As Boolean, Optional ByVal zKillFirst As Boolean = False _
    , Optional ByVal zRecurse As Boolean = False) As Byte
'v8.00 2014-01-08 10:37 - added Z7_Force_Connection
'v6.00 2013-08-08 10:48
'find/setup 7zip on user's PC, and zip/unzip files
'original source:

Dim ZIP_EXE As String, ZIP_CMD As String, ZIP_DEBUG As String, rslt As Byte
Dim qm As String
qm = Chr(34)

'check/force connection to specified path
If Z7_Force_Connection(zArchive) = False Then
'can't connect, don't do it
    rslt = 99
    GoTo ErrorHandler
End If

'get ZIP_EXE, runs very long function, skip this when reviewing code stepwise

If zKillFirst = True Then
    If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = "Deleting existing archive... || " & zArchive
    If Dir(zArchive) <> "" Then Kill zArchive   'write access is required for this location to Kill and then to Zip
    If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = False
End If

ZIP_EXE = qm & ZIP_EXE & qm
zArchive = qm & zArchive & qm
zPathFiles = qm & zPathFiles & qm

Dim zAction As String, zSwitches As String
If ZIP_IT = True Then
'append the source file to the target zip
    'syntax: 7zip a <archive> <sourceFILE>
    zAction = " a "
    If InStr(zPathFiles, ".") = 0 Then Debug.Print "ZIP_CMD: file extension not specified in add path, maybe OK, zPathFiles:=" & zPathFiles & vbLf
    zPathFiles = " " & zPathFiles
    zSwitches = ""
'extract the target zip to the 7z working directory and overwrite existing files
    'syntax: 7zip e <archive> -o<outputPATH> -y
    zAction = " e "
    If InStr(zPathFiles, ".") <> 0 Then ZIP_DEBUG = ZIP_DEBUG & "ZIP_CMD: file extension should not be specified in extract path, maybe OK, zPathFiles:=" & zPathFiles & vbLf
    zPathFiles = " -o" & zPathFiles
    zSwitches = " -y "
End If

If zRecurse = True Then zSwitches = zSwitches & " -r "

'set the command line
ZIP_CMD = ZIP_EXE & zAction & zArchive & zPathFiles & zSwitches
ZIP_DEBUG = ZIP_DEBUG & "ZIP_CMD: [" & ZIP_CMD & "]" & vbLf

'do the zipping
If InStr(Application.Name, "Excel") > 0 Then
'use xlShellAndWait
    Application.StatusBar = "Zipping to " & zArchive
    rslt = val(ShellAndWait(ZIP_CMD, 0, vbHide, PromptUser))
    ZIP_DEBUG = ZIP_DEBUG & "ShellAndWait result: " & rslt
'just use Shell
    Shell ZIP_CMD
End If

'debug only on error
If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = False
If rslt <> 0 Then
    Debug.Print ZIP_DEBUG
    If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = "Zip failed, check Debug window || " & zArchive
End If
Zip7Sub = rslt

End Function

Function ZIP_EXE_copy() As String
'v7.00 2013-08-15 12:58
'installs (copies) 7za.exe from remote location to local folder
'returns path & fn for copied file (or "" if not copied)

If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = "Checking local machine for 7zip..."

Dim ZIP_PTH(0 To zlmax) As String, z As Byte, pp As String
Const tt As String = "Error in macro: ZIP_EXE_copy"
Dim ZIP_EXE As String

'check and/or create local 7zip app location
ZIP_EXE = ZIP_EXE_pthfn(zSubFolder)      'local pth & fn
ZIP_PTH(0) = Replace(ZIP_EXE, z7exe, "") 'local path
'specify shared drive / iShare ZIP_EXE locations
'if ZIP_PTH(0) not found, looks for z7eN (but only if zlmax >= N)
If zlmax >= 1 Then ZIP_PTH(1) = z7e1
If zlmax >= 2 Then ZIP_PTH(2) = z7e2
'If zlmax >= 3 Then ZIP_PTH(3) = z7e3
'If zlmax >= 4 Then ZIP_PTH(4) = z7e4
'If zlmax >= 5 Then ZIP_PTH(5) = z7e5 'can add more if ever needed

'test access to specified ZIP_PTH(z) location
For z = 0 To zlmax
'0 is local location, preferred, only looks for 1 if 0 not found
    If z > 0 Then If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = "Checking remote locations for 7zip || " & ZIP_PTH(z)
On Error Resume Next
    If Dir(ZIP_PTH(z), vbDirectory) = "." Then
    'folder exists, check for z7exe OR z7ext OR z7exn
    'look for z7exe in ZIP_PTH(z)  (usually "7za.exe")
        ZIP_EXE_copy = Dir(ZIP_PTH(z) & z7exe)  'sets this to z7exe if found
        If ZIP_EXE_copy = z7exe Then Exit For
    'look for z7ext in ZIP_PTH(z)  (usually "7za.ext")
        ZIP_EXE_copy = Dir(ZIP_PTH(z) & z7ext)  'sets this to z7ext if found
        If ZIP_EXE_copy = z7ext Then Exit For
    'look for z7exn in ZIP_PTH(z)  (usually "7za")  'v5.01
        ZIP_EXE_copy = Dir(ZIP_PTH(z) & z7exn)  'sets this to z7exn if found
        If ZIP_EXE_copy = z7exn Then Exit For
On Error GoTo 0
    End If
    'folder not found, try the next z
Next z
If ZIP_EXE_copy = vbNullString Then
    pp = "Cannot find 7zip application"
    MsgBox pp, vbCritical, tt
    If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = False
    Exit Function
    If z > 0 And z <= zlmax Then
        If InStr(UCase(Application.Name), UCase("Excel")) > 0 Then Application.StatusBar = "Copying 7zip to local machine..."
        FileCopy ZIP_PTH(z) & ZIP_EXE_copy, ZIP_EXE  'renames to z7exe at destination, regardless of source filename
        If Dir(ZIP_PTH(0) & z7exe) <> z7exe Then
            pp = "Cannot copy 7zip application" & vbLf & "from:  " & vbLf & ZIP_PTH(z) & vbLf & "to:  " & ZIP_PTH(0)
            MsgBox pp, vbCritical, tt
            ZIP_EXE_copy = vbNullString
            If InStr(UCase(Application.Name), UCase("Excel")) > 0 Then Application.StatusBar = False
            Exit Function
        End If
    End If
End If

If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = False


End Function

Private Function ZIP_EXE_pthfn(Optional zUserSubFolder As String) As String
'v7.00 2013-08-15 12:10
'determines (and creates) usable ZIP_EXE location on user's PC

'for Windows 7:
'   > primary:   C:\Users\All Users\<zUserSubFolder>\7z\
'   > secondary: C:\Users\<userID>\AppData\<zUserSubFolder>\7z\
'   > tertiary:  C:\Users\<userID>\Documents\<zUserSubFolder>\7z\

'for Windows XP:
'   > primary:   C:\Documents and Settings\All Users\Application Data\<zUserSubFolder>\7z\
'   > secondary: C:\Documents and Settings\<userID>\Application Data\<zUserSubFolder>\7z\
'   > tertiary:  C:\Documents and Settings\<userID>\My Documents\<zUserSubFolder>\7z\

Dim objFolders As Object, pth As String, fn As String
Set objFolders = CreateObject("WScript.Shell").SpecialFolders

Dim zInstallPath As String

On Error Resume Next
'primary:    \All Users\AppData\
    zInstallPath = zpth_sl(SpecFolder(CSIDL_COMMON_APPDATA))
    If zTestFolder(zInstallPath) = True Then GoTo zContinue
'secondary:  \<userID>\AppData\
    zInstallPath = zpth_sl(SpecFolder(CSIDL_APPDATA))
    If zTestFolder(zInstallPath) = True Then GoTo zContinue
'tertiary:   \<userID>\Documents\
    zInstallPath = zpth_sl(SpecFolder(CSIDL_PERSONAL))
    If zTestFolder(zInstallPath) = True Then GoTo zContinue

On Error GoTo 0

If zUserSubFolder <> vbNullString Then
'user specified subfolder, clean it first
    zInstallPath = zInstallPath & zpth_sl(zfn_val(zUserSubFolder))   'removes special chars EXCEPT \
'user didn't specify subfolder, use default Private Const zSubFolder
    zInstallPath = zInstallPath & zpth_sl(zfn_val(zSubFolder))  'removes special chars EXCEPT \
End If
If Dir(zInstallPath, vbDirectory) <> "." Then MkDir zInstallPath

zInstallPath = zInstallPath & zpth_sl(z7pth)
If Dir(zInstallPath, vbDirectory) <> "." Then MkDir zInstallPath

ZIP_EXE_pthfn = zInstallPath & z7exe

Set objFolders = Nothing

End Function

Function zTestFolder(zTestPath) As Boolean
'v7.00 2013-08-15 11:48
'tests whether zTestPath is writeable by user

Const zt As String = "ztest"
Dim zp As String
zp = zpth_sl(zTestPath) & zpth_sl(zt)
On Error Resume Next
    MkDir zp
    If Dir(zp, vbDirectory) = "." Then zTestFolder = True Else Exit Function
    If zTestFolder = True Then RmDir zTestPath 'NB: only removes if empty
On Error GoTo 0

End Function

Function zpth_sl(ByVal PathToAddSlash As String, Optional DoURL As Boolean) As String
'v6.01 2013-08-15 11:37
'copied from CIRFiShare v2.36 2012-11-09 12:40
'adds a slash to end of path as required
'DoURL tries to force UNC but will be overridden if URL is 'detected'

Const cFsl As String = "/"  'URL
Const cBsl As String = "\"  'UNC
Const cURL As String = "http://"

'!! can only specify URL if DoURL=True
If DoURL = True And Left(PathToAddSlash, Len(cURL)) <> cURL Then _
    MsgBox "a URL must be specified if DoURL=True", vbCritical, "error in zpth_sl"

'if Path includes http then override DoURL (NB: fn_ipth will determine UNC or URL)
If DoURL = False And Left(PathToAddSlash, Len(cURL)) = cURL Then _
    DoURL = True

If DoURL = True And Right(PathToAddSlash, 1) <> cFsl Then
    zpth_sl = PathToAddSlash & cFsl
    Exit Function
ElseIf Right(PathToAddSlash, 1) <> cBsl Then
    zpth_sl = PathToAddSlash & cBsl
    Exit Function
    zpth_sl = PathToAddSlash
End If

End Function

Private Function zfn_val(sFileName As String, Optional sReplaceInvalidWith As String = "") As String
'v3.00 2012-11-01 12:05
'Purpose   :    Removes invalid characters from a filename
'Inputs    :    sFileName               The file name to clean the invalid characters from.
'               [sReplaceInvalidWith]   The text to replace any invalid characters with.
'Outputs   :    Returns a valid filename.
'Author    :    Andrew Baker
'Date      :    25/03/2001
'Notes     :

'NB: modZip version allows backslash
'Const csInvalidChars As String = ":\/?*<>|"""
Const csInvalidChars As String = ":/?*<>|"""

Dim lThisChar As Long
zfn_val = sFileName
'Loop over each invalid character, removing any instances found
For lThisChar = 1 To Len(csInvalidChars)
    zfn_val = Replace$(zfn_val, Mid(csInvalidChars, lThisChar, 1), sReplaceInvalidWith)

End Function

Sub syntax_to_zip_one_file()
'v7.02 2013-11-05 15:53
'this example zips all .bas files to iShare (write access to BPMPrivate is required)

    Dim zsrc() As String, ztgt As String, spth As String, ipth As String, fn As String
    spth = "\\GBMNCWSA050\BPMpublic\VBA Modules\" 'v4.02
'On Error Resume Next
'    zsrc = Dir(spth, vbDirectory)
'On Error GoTo 0
    ipth = "\\\sites\DGFUK\BPMpublic\VBA Modules\"
    ReDim zsrc(0 To 2) As String
    zsrc(0) = spth & "*.rwz"    'Outlook Rules
    zsrc(1) = spth & "*.docx"   'documentation
    zsrc(2) = spth & "*.bas"    'VB modules
    ztgt = ipth & "VBA"

    If Dir(zsrc(0)) = vbNullString Then MsgBox "zsrc not found"
    If InStr(Application.Name, "Excel") > 0 Then
    'if running from Excel: ShellAndWaitResult = Zip7Sub() As Byte
        If Zip7Sub(zsrc(0), ztgt, True, True, True) = 0 _
        And Zip7Sub(zsrc(1), ztgt, True, False, True) = 0 _
        And Zip7Sub(zsrc(2), ztgt, True, False, True) = 0 Then
            MsgBox "Success!", vbInformation
            MsgBox "Failed!", vbExclamation
        End If
    'don't use xlShellAndWait if not in Excel
On Error Resume Next
        Kill ztgt    'error here means no connection to tgt
        Zip7Sub zsrc(0), ztgt, True, True, True     'kill first
        Zip7Sub zsrc(1), ztgt, True, False, True    'add to zip
        Zip7Sub zsrc(2), ztgt, True, False, True    'add to zip
        Sleep zSleepTime
        If Dir(ztgt) = "" Then
            MsgBox "Failed! (But try a longer zSleepTime before panicking)", vbExclamation
            MsgBox "Success!", vbInformation
        End If
On Error GoTo 0
    End If

End Sub

Function Z7_Force_Connection(ByVal LocalOrUNC_PathOrFile As String _
    , Optional ByVal bExplorerKill As Boolean = True) As Boolean
'v8.04 2014-01-10 14:27 - bugfix for zips (remove "" from ends)
'v8.01 2014-01-09 15:46 - added bExplorerKill failsafe option to kill all Explorer windows (prevents leaving countless processes open - although rarely triggered)
'v8.00 2014-01-08 10:28 - adapted from xlSharePoint v5.03
'v5.03 2014-01-08 10:24 - now accepts filenames at end of path
'v5.02 2013-12-18 10:28 - added option for default UNCpath
'v5.00 2013-12-02 16:17
'NB: not suitable for end user processes, may close ALL instances of Windows Explorer (file browser)
'1. launches UNC in Explorer window
'2. tries to close Explorer
'3. if 2 unsuccessful, kills all instances of Explorer then relaunches Taskbar

'remove file name from pthfn and extract last folder name for Windows Explorer title bar
Dim p As String, f As String, b As Integer, s() As Integer, c As Byte
p = Replace(LocalOrUNC_PathOrFile, Chr(34), "")
b = InStr(p, "\")
While b > 0
    c = c + 1  'count slashes
    ReDim Preserve s(1 To c) As Integer  'add another slash character count
    s(c) = b
    b = InStr(s(c) + 1, p, "\")
If c > 0 Then
    p = Left(p, s(c))   'full 'root' path without last filename (or folder name) so "C:\Folder\Filename.txt" > "C:\Folder\"
    f = Mid(p, s(c - 1) + 1, s(c) - 1 - s(c - 1))   'folder name (in Explorer title bar) so "C:\Folder\Filename.txt" > "Folder"
End If

Z7_Force_Connection = True

'easy option first, see if UNC already connected
On Error Resume Next
Dim testfn As String
testfn = Dir(p, vbDirectory)
If testfn = "." Then Exit Function
On Error GoTo 0

'open UNC in Explorer, try to close specific Explorer window
ShellAndWait "explorer " & p, 10000, vbHide, AbandonWait
If Z7_CloseExplorerWindow(f) = False Then  'v5.00
'couldn't kill this specific opened Explorer task window
    If bExplorerKill Then  'v8.01
    'use brute force, close all Explorer windows, then relaunch Taskbar
        ShellAndWait "TaskKill /F /IM ""explorer.exe""", 1000, vbHide, AbandonWait
        Shell "C:\Windows\explorer.exe"
    End If
End If

'test UNC connection
On Error Resume Next
testfn = Dir(p, vbDirectory)
If testfn <> "." Then Z7_Force_Connection = False
On Error GoTo 0

End Function

Function Z7_CloseExplorerWindow(ByVal sCurrentFolderName As String) As Boolean
'v8.03 2014-01-09 18:12 - bugfix
'v8.02 2014-01-09 17:10 - bugfix
'v8.00 2014-01-08 10:09 - adapted from xlSharePoint v5.03
'v5.00 2013-12-02 16:12
'Function returns "True" if successful, otherwise "False"
'Amended from Source:

Dim bTest, wndw
bTest = False
With CreateObject("shell.application")
    For Each wndw In .Windows
        If wndw = "Windows Explorer" Then
        If wndw.Document.Folder = sCurrentFolderName Then
            On Error Resume Next
            bTest = Err.Number = 0
            On Error GoTo 0
        End If
        End If
End With ' shell.application
Z7_CloseExplorerWindow = CStr(bTest)

End Function

No comments:

Post a Comment