In this installment … I thought I’d try and cover the wonderful world of the Shell.Application and illustrate some of its numerous capabilities:
- Open file, folders, URLs, …
- Get shell settings
- Get information about the system
- Get system folder paths
- Desktop
- Profile
- StartUp
- Many, many more …
- Work with Folders and Files
- Folder Picker/Dialog
- Open Windows Explorer To A Specific Folder
- Determine If A Folder Exists
- Determine If A File Exists
- Create A Directory Structure/Nested Folders
- List SubFolders (recursively if wanted)
- List Files in a Folder or Zip File (recursively if wanted)
- Unzip a Zipped File/Folder
- Extract a Single File from a Zipped File/Folder
- Create a Zip File – Zip Folder or Files
- and much, much more.
Creating A Shell.Application Variable
Early Binding
Requires that the ”Microsoft Shell Controls And Automation’ VBA Reference be added.
Dim oShell As Shell32.Shell Set oShell = New Shell32.Shell
Late Binding
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
Best of Both World!
Or, you can use conditional formatting to allow for easy switching and use Early Binding for development and toggle it to Late Binding for final testing and deployment!
#Const Shell32_EarlyBind = True 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
'Microsoft Shell Controls And Automation
Dim oShell As Shell32.Shell
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
#End If
Great Opportunity!
This would be a great opportunity to implement a Self-Healing Object Variable (SHOV) for the oShell variable! Learn more by reviewing:
Self-Healing Object Variables
So what does a developer do when he can’t sleep at 3am? He decides to write an article about self-healing object variables! So What Are Self-Healing Object Variables? In plain English, these are variables that are intelligent enough that they initialize themselves once and retain their value for the entire session. If reset, they will…
A Helping Hand
To facilitate coding, I created the following Enums:
Enum ShellSpecialFolderConstants
'https://learn.microsoft.com/en-us/windows/win32/api/shldisp/ne-shldisp-shellspecialfolderconstants
ssfDESKTOP = 0
ssfPROGRAMS = 2 '0x2
ssfCONTROLS = 3 '0x3
ssfPRINTERS = 4 '0x4
ssfPERSONAL = 5 '0x5
ssfFAVORITES = 6 '0x6
ssfSTARTUP = 7 '0x7
ssfRECENT = 8 '0x8
ssfSENDTO = 9 '0x9
ssfBITBUCKET = 10 '0xa
ssfSTARTMENU = 11 '0xb
ssfDESKTOPDIRECTORY = 16 '0x10
ssfDRIVES = 17 '0x11 - ThisPC
ssfNETWORK = 18 '0x12
ssfNETHOOD = 19 '0x13
ssfFONTS = 20 '0x14
ssfTEMPLATES = 21 '0x15
ssfCOMMONSTARTMENU = 22 '0x16
ssfCOMMONPROGRAMS = 23 '0x17
ssfCOMMONSTARTUP = 24 '0x18
ssfCOMMONDESKTOPDIR = 25 '0x19
ssfAPPDATA = 26 '0x1a
ssfPRINTHOOD = 27 '0x1b
ssfLOCALAPPDATA = 28 '0x1c
ssfALTSTARTUP = 29 '0x1d
ssfCOMMONALTSTARTUP = 30 '0x1e
ssfCOMMONFAVORITES = 31 '0x1f
ssfINTERNETCACHE = 32 '0x20
ssfCOOKIES = 33 '0x21
ssfHISTORY = 34 '0x22
ssfCOMMONAPPDATA = 35 '0x23
ssfWINDOWS = 36 '0x24
ssfSYSTEM = 37 '0x25
ssfPROGRAMFILES = 38 '0x26
ssfMYPICTURES = 39 '0x27
ssfPROFILE = 40 '0x28
ssfSYSTEMx86 = 41 '0x29
ssfPROGRAMFILESx86 = 48 '0x30
End Enum
Enum ShellSystemSettingConstants
'https://learn.microsoft.com/en-us/windows/win32/shell/shell-getsetting
SSF_AUTOCHECKSELECT = 8388608 '0x00800000
'SSF_DESKTOPHTML = 512 '0x00000200 'Not Used
SSF_DONTPRETTYPATH = 2048 '0x00000800
SSF_DOUBLECLICKINWEBVIEW = 128 '0x00000080
'SSF_FILTER = 65536 '0x00010000 'Not Used
'SSF_HIDDENFILEEXTS = 4 '0x00000004 'Not Used
SSF_HIDEICONS = 16384 '0x00004000
SSF_ICONSONLY = 16777216 '0x01000000
SSF_MAPNETDRVBUTTON = 4096 '0x00001000
SSF_NOCONFIRMRECYCLE = 32768 '0x00008000
SSF_NONETCRAWLING = 1048576 '0x00100000
SSF_SEPPROCESS = 524288 '0x00080000
'SSF_SERVERADMINUI = 4 '0x00000004 'Not Used
SSF_SHOWALLOBJECTS = 1 '0x00000001
SSF_SHOWATTRIBCOL = 256 '0x00000100
SSF_SHOWCOMPCOLOR = 8 '0x00000008
SSF_SHOWEXTENSIONS = 2 '0x00000002
SSF_SHOWINFOTIP = 8192 '0x00002000
'SSF_SHOWSTARTPAGE = 4194304 '0x00400000 'Not Used
SSF_SHOWSUPERHIDDEN = 262144 '0x00040000
SSF_SHOWSYSFILES = 32 '0x00000020
SSF_SHOWTYPEOVERLAY = 33554432 '0x02000000
'SSF_SORTCOLUMNS = 16 '0x00000010 'Not Used
SSF_STARTPANELON = 2097152 '0x00200000
SSF_WEBVIEW = 131072 '0x00020000
SSF_WIN95CLASSIC = 1024 '0x00000400
End Enum
which you will see used in some of the examples below. So be sure to copy these as well!
Opening Folders, Files, URLS …
The shell object gives us the ability to open System Folders, Folders, Files, URLS … up in the default associate application.
The basic syntax being:
CreateObject("Shell.Application").Open("C:\Temp\")
OR
CreateObject("Shell.Application").Open("C:\Temp\Book1.xlsx")
OR
CreateObject("Shell.Application").Open("https://www.devhut.net")
With that in mind, I created the following function:
'---------------------------------------------------------------------------------------
' Procedure : Shell_Open
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Opens the specified item in the default associated application
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' vDir : ShellSpecialFolderConstants, folder, file, URL to open
'
' Usage:
' ~~~~~~
' Call Shell_Open(ssfPROFILE)
' Call Shell_Open("C:\Temp\")
' Call Shell_Open("C:\Temp\Book1.xls")
' Call Shell_Open("https://www.devhut.net")
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-03
'---------------------------------------------------------------------------------------
Sub Shell_Open(vDir As Variant)
On Error GoTo Error_Handler
#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
#End If
Call oShell.Open(vDir)
Error_Handler_Exit:
On Error Resume Next
Set oShell = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_Open" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
and as shown in the function header we can then use it by simply doing:
Shell_Open(ssfPROFILE)
OR
Shell_Open("C:\Temp\")
OR
Shell_Open("C:\Temp\Book1.xlsx")
OR
Shell_Open("https://www.devhut.net")
Retrieving Shell Settings
Shell can be used to get the current settings and the basic syntax is:
CreateObject("Shell.Application").GetSetting(2)
This of course can be turned into a reusable function with proper error handling, by simply doing:
'---------------------------------------------------------------------------------------
' Procedure : Shell_GetSetting
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Retrieve Shell Setting Value
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
' Dependencies: ShellSystemSettingConstants Enum
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' lSetting : The ShellSystemSettingConstants representing the setting you wish to
' retrieve the value of.
'
' Usage:
' ~~~~~~
' Shell_GetSetting(SSF_SHOWEXTENSIONS)
' Returns -> True
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-04
'---------------------------------------------------------------------------------------
Function Shell_GetSetting(lSetting As ShellSystemSettingConstants)
On Error GoTo Error_Handler
#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
#End If
Shell_GetSetting = oShell.GetSetting(lSetting)
Error_Handler_Exit:
On Error Resume Next
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_GetSetting" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
and this way we have intellisense when using the function because of the Enum! So we can use it by doing
? Shell_GetSetting(SSF_SHOWEXTENSIONS)
OR
If Shell_GetSetting(SSF_SHOWEXTENSIONS) Then
'...
End If
Get System Information
Shell also give us access to certain information regarding the system: Processor Speed, Physical Memory Installed, …
The basic syntax being:
CreateObject("Shell.Application").GetSystemInformation("ProcessorSpeed")
Thus, we can build a proper function like:
'---------------------------------------------------------------------------------------
' Procedure : Shell_GetSystemInformation
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Retrieve System Information
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sName : Name of the system information that is being requested
'
' Usage:
' ~~~~~~
' Shell_GetSystemInformation("ProcessorSpeed")
' Returns -> 2208
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-04
'---------------------------------------------------------------------------------------
Function Shell_GetSystemInformation(sName As String) As Variant
On Error GoTo Error_Handler
#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
#End If
Shell_GetSystemInformation = oShell.GetSystemInformation(sName)
Error_Handler_Exit:
On Error Resume Next
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_GetSystemInformation" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
and then use it by doing:
? Shell_GetSystemInformation("DirectoryServiceAvailable")
? Shell_GetSystemInformation("ProcessorSpeed")
? Shell_GetSystemInformation("PhysicalMemoryInstalled")
? Shell_GetSystemInformation("IsOS_DomainMember")
The list of System elements that you can request/query is:
- DirectoryServiceAvailable
- DoubleClickTime
- ProcessorLevel
- ProcessorSpeed
- ProcessorArchitecture
- PhysicalMemoryInstalled
- IsOS_Professional
- IsOS_Personal
- IsOS_DomainMember
which was taken from:
Shell.GetSystemInformation method (Shldisp.h) - Win32 apps
Shell.GetSystemInformation method - Retrieves system information.
Get System Folder Paths
Shell gives us the ability to easily retrieve the paths to various system folders, some people refer to them a special folders. The basic syntax being:
CreateObject("Shell.Application").NameSpace(ssfDESKTOP).Self.Path
Building upon this, we end up with a function like:
'---------------------------------------------------------------------------------------
' Procedure : Shell_GetSystemFolderPath
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Retrieve the path to the specified system folder
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
' Dependencies: ShellSpecialFolderConstants Enum
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFolderName : The Folder name you wish to get the full path of
'
' Usage:
' ~~~~~~
' Shell_GetSystemFolderPath(ssfDESKTOP)
' Returns -> C:\Users\Dev\Desktop
'
' Shell_GetSystemFolderPath(ssfPROGRAMFILES)
' Returns -> C:\Program Files (x86)
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-04
'---------------------------------------------------------------------------------------
Function Shell_GetSystemFolderPath(sFolderName As ShellSpecialFolderConstants) As String
On Error GoTo Error_Handler
#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
#End If
Shell_GetSystemFolderPath = oShell.NameSpace((sFolderName)).Self.Path
Error_Handler_Exit:
On Error Resume Next
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_GetSystemFolderPath" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
and then we can use it by doing:
? Shell_GetSystemFolderPath(ssfDESKTOP)
which returns something along the lines of:
C:\Users\Dev\Desktop
Or
? Shell_GetSystemFolderPath(ssfPROGRAMFILES)
which returns something along the lines of:
C:\Program Files (x86)
Working With Folders And Files
Below are a series of function that use Shell.Application to work with folders and file.
Folder Picker/Dialog
'---------------------------------------------------------------------------------------
' Procedure : Shell_BrowseForFolder
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Folder Picker Dialog
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
' References:
' https://learn.microsoft.com/en-us/windows/win32/shell/shell-browseforfolder
' Dependencies: ShellSpecialFolderConstants Enum
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sTitle : The title to give to the Folder Browsing Dialog
' lInitialFolder: The initial directory to load in the Dialog
' lHwnd : Option Hwnd of the parent window. Could be the App Hwnd,
' Form Hwnd, ... or omit it altogether.
' Using a value avoid it getting pushed backwards and potentially
' Not being visible. Recommend using a value.
'
' Usage:
' ~~~~~~
' ? Shell_BrowseForFolder("Pick a Folder",ssfPROFILE, Application.hWndAccessApp)
' Returns -> C:\Users\Dev\Desktop 'Whatever the user picks
'
' ? Shell_BrowseForFolder("Pick a Folder",ssfWindows)
' Returns -> C:\Temp 'Whatever the user picks
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-04
'---------------------------------------------------------------------------------------
Function Shell_BrowseForFolder(sTitle As String, _
lInitialFolder As ShellSpecialFolderConstants, _
Optional lHwnd As Long = 0) As String
On Error GoTo Error_Handler
'#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Dim oFolder As Shell32.Folder
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Dim oFolder As Object
Set oShell = CreateObject("Shell.Application")
#End If
Set oFolder = oShell.BrowseForFolder(lHwnd, sTitle, 0, (lInitialFolder))
If Not oFolder Is Nothing Then
Shell_BrowseForFolder = oFolder.Self.Path
End If
Error_Handler_Exit:
On Error Resume Next
Set oFolder = Nothing
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_BrowseForFolder" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Open Windows Explorer To A Specific Folder
'---------------------------------------------------------------------------------------
' Procedure : Shell_LaunchWindowsExplorer
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Open Windows Explorer to a specific folder.
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
' References:
' https://learn.microsoft.com/en-us/windows/win32/shell/shell-explore
' Can also use Shell_Open function to do the same and more
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFolder : Folder to open Windows Explorer to
' Can be a string input or ShellSpecialFolderConstants Enum
'
' Usage:
' ~~~~~~
' ? Shell_LaunchWindowsExplorer(ssfPROFILE)
' Returns -> True
'
' ? Shell_LaunchWindowsExplorer("C:\NonExistentFolder\")
' Returns -> False
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-04
'---------------------------------------------------------------------------------------
Function Shell_LaunchWindowsExplorer(sFolder As Variant) As Boolean
On Error GoTo Error_Handler
#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Dim oFolder As Shell32.Folder
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Dim oFolder As Object
Set oShell = CreateObject("Shell.Application")
#End If
Set oFolder = oShell.NameSpace(sFolder)
If Not oFolder Is Nothing Then
Call oShell.Explore(sFolder)
Shell_LaunchWindowsExplorer = True
End If
Error_Handler_Exit:
On Error Resume Next
Set oFolder = Nothing
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_LaunchWindowsExplorer" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Determine If A Folder Exists
'---------------------------------------------------------------------------------------
' Procedure : Shell_FolderExist
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Determine if the specified path/folder exists or not
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFolder : Path/Folder to validate
' Can be a string input or ShellSpecialFolderConstants Enum
'
' Usage:
' ~~~~~~
' ? Shell_FolderExist("C:\Users\")
' Returns -> True
'
' ? Shell_FolderExist("C:\NonExistentFolder\")
' Returns -> False
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-04
'---------------------------------------------------------------------------------------
Function Shell_FolderExist(sFolder As Variant) As Boolean
On Error GoTo Error_Handler
#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Dim oFolder As Shell32.Folder
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Dim oFolder As Object
Set oShell = CreateObject("Shell.Application")
#End If
Set oFolder = oShell.NameSpace(sFolder)
If Not oFolder Is Nothing Then Shell_FolderExist = True
Error_Handler_Exit:
On Error Resume Next
Set oFolder = Nothing
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_FolderExist" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Determine If A File Exists
'---------------------------------------------------------------------------------------
' Procedure : Shell_FileExist
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Determine if the specified file exists or not
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile : Fully qualified path and filename of the file to check the existence of
'
' Usage:
' ~~~~~~
' ? Shell_FileExist("C:\Temp\Book1.xlsx")
' Returns -> True/False
'
' ? Shell_FileExist(Shell_GetSystemFolderPath(ssfDESKTOP) & "\MyFile.accdb")
' Returns -> True/False
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-04
'---------------------------------------------------------------------------------------
Function Shell_FileExist(sFile As Variant) As Boolean
On Error GoTo Error_Handler
'#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Dim oFolderItem As Shell32.FolderItem
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Dim oFolderItem As Object
Set oShell = CreateObject("Shell.Application")
#End If
Set oFolderItem = oShell.NameSpace(sFile)
If Not oFolderItem Is Nothing Then Shell_FileExist = True
Error_Handler_Exit:
On Error Resume Next
Set oFolderItem = Nothing
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_FileExist" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Now, although the above does work in my testing, but since the documentation states:
The folder for which to create the Folder object.
Object reference to the Folder object for the specified folder
where NameSpace supposedly always refers to the Folder, not a file, we are better modifying the above, to be 100% safe, and instead doing something more like:
'---------------------------------------------------------------------------------------
' Procedure : Shell_FileExist
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Determine if the specified file exists or not
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile : Fully qualified path and filename of the file to check the existence of
'
' Usage:
' ~~~~~~
' ? Shell_FileExist("C:\Temp\Book1.xlsx")
' Returns -> True/False
'
' ? Shell_FileExist(Shell_GetSystemFolderPath(ssfDESKTOP) & "\MyFile.accdb")
' Returns -> True/False
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-04
'---------------------------------------------------------------------------------------
Function Shell_FileExist(sFile As Variant) As Boolean
On Error GoTo Error_Handler
#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Dim oFolder As Shell32.Folder
Dim oFolderItem As Shell32.FolderItem
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Dim oFolder As Object
Dim oFolderItem As Object
Set oShell = CreateObject("Shell.Application")
#End If
Dim sPath As String
Dim sFileName As String
sPath = Left(sFile, InStrRev(sFile, "\"))
sFileName = Right(sFile, Len(sFile) - InStrRev(sFile, "\"))
Set oFolder = oShell.NameSpace((sPath))
If Not oFolder Is Nothing Then
Set oFolderItem = oFolder.ParseName(sFileName)
If Not oFolderItem Is Nothing Then Shell_FileExist = True
End If
Error_Handler_Exit:
On Error Resume Next
Set oFolderItem = Nothing
Set oFolder = Nothing
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_FileExist" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Create A Directory Structure/Nested Folders
'---------------------------------------------------------------------------------------
' Procedure : Shell_MakeFolderStructure
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Pass a path and it creates any non-existant folders in that paths
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
' References: https://learn.microsoft.com/en-us/windows/win32/shell/folder-newfolder
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sPath : Path to create
'
' Usage:
' ~~~~~~
' Shell_MakeFolderStructure("C:\Temp\Test1\Test2\Test3\Test4")
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-04
'---------------------------------------------------------------------------------------
Function Shell_MakeFolderStructure(sPath As Variant) As Boolean
On Error GoTo Error_Handler
#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Dim oFolder As Shell32.Folder
Dim oFolderNew As Shell32.Folder
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Dim oFolder As Object
Dim oFolderNew As Object
Set oShell = CreateObject("Shell.Application")
#End If
Dim aDirs As Variant
Dim sCurDir As String
Dim i As Integer
If sPath <> "" Then
aDirs = Split(sPath, "\")
sCurDir = Left(sPath, InStr(1, sPath, "\"))
Set oFolder = oShell.NameSpace((sCurDir))
For i = 1 To UBound(aDirs)
sCurDir = sCurDir & aDirs(i) & "\"
Set oFolderNew = oShell.NameSpace((sCurDir))
If oFolderNew Is Nothing Then
Debug.Print "Creating folder " & aDirs(i)
oFolder.NewFolder aDirs(i)
End If
Set oFolder = oShell.NameSpace((sCurDir))
Next i
End If
Shell_MakeFolderStructure = True
Error_Handler_Exit:
On Error Resume Next
Set oFolder = Nothing
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_MakeFolderStructure" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
List SubFolders
'---------------------------------------------------------------------------------------
' Procedure : Shell_ListSubFolders
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : List the subfolders of the specified folder, recursive if wanted
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sPath : Folder to list subfolders of
' bProcessSubDirs : Whether to recursively process subfolders, or not.
' True => Process subfolders recursively
' False => Do not process subfolders
'
' Usage:
' ~~~~~~
' Shell_ListSubFolders("C:\Temps")
' Returns => List of all subfolders, and recursively processes
'
' Shell_ListSubFolders("C:\Temps", False)
' Returns => Top level subfolder and does not recursively process
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2020-04-22
' 2 2023-03-05 Updated for blog posting
'---------------------------------------------------------------------------------------
Function Shell_ListSubFolders(ByVal sPath As String, _
Optional bProcessSubFolders As Boolean = True)
On Error GoTo Error_Handler
#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Dim oFolder As Shell32.Folder
Dim oFolderItems As Shell32.FolderItems
Dim oFolderItem As Shell32.FolderItem
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Dim oFolder As Object
Dim oFolderItems As Object
Dim oFolderItem As Object
Set oShell = CreateObject("Shell.Application")
#End If
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
Set oFolder = oShell.NameSpace((sPath))
If Not oFolder Is Nothing Then
Set oFolderItems = oFolder.Items()
If (Not oFolderItems Is Nothing) Then
For Each oFolderItem In oFolderItems
'If oFolderItem.IsFolder Then '*****No good as criteria as it includes 'Compressed (zipped) Folder'?!
If oFolderItem.Type = "File folder" Then
Debug.Print sPath & oFolderItem.Name
'oFolderItem.Path 'Same as oFolderItem.Name
'oFolderItem.Type
'oFolderItem.Size doesn't work on folders
If bProcessSubFolders = True Then
Call Shell_ListSubFolders(sPath & oFolderItem.Name, bProcessSubFolders)
End If
End If
Next oFolderItem
End If
End If
Error_Handler_Exit:
On Error Resume Next
Set oFolderItem = Nothing
Set oFolderItems = Nothing
Set oFolder = Nothing
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Shell_ListSubFolders" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
List Files In Folder or Zip File
'---------------------------------------------------------------------------------------
' Procedure : Shell_ListFilesInFolder
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Enumerate the files in a folder, recursively if wanted
' Can enumerate files in Zip files/folders as well
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sPath : Folder to list subfolders of
' vFilter : Search filter to restrict results with.
' * is the wildcard character
' bProcessSubDirs : Whether to recursively process subfolders, or not.
' True => Process subfolders recursively
' False => Do not process subfolders
'
' Usage:
' ~~~~~~
' Shell_ListFilesInFolder "C:\Temp", "*test*", False
' Returns -> Lists all the files with the word test in it in the folder C:\Temp
'
' Shell_ListFilesInFolder "C:\Temp", "*.xls", False
' Returns -> Lists all the files ending with the extension xls in the folder C:\Temp
'
' Shell_ListFilesInFolder "C:\Temp\", "*.xl*", True
' Returns -> Lists all the files ending with the extension xl* in the folder C:\Temp
' or any of its subfolders
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2020-04-22
' 2 2023-03-05 Updated for blog posting
'---------------------------------------------------------------------------------------
Function Shell_ListFilesInFolder(ByVal sPath As String, _
Optional ByVal vFilter As Variant, _
Optional bProcessSubFolders As Boolean = True) As Variant
#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Dim oFolder As Shell32.Folder
Dim oFolderItems As Shell32.FolderItems
Dim oFolderItem As Shell32.FolderItem
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Dim oFolder As Object
Dim oFolderItems As Object
Dim oFolderItem As Object
Set oShell = CreateObject("Shell.Application")
#End If
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
Set oFolder = oShell.NameSpace((sPath))
If Not oFolder Is Nothing Then
Set oFolderItems = oFolder.Items()
If Not oFolderItems Is Nothing Then
If IsMissing(vFilter) = True Or IsNull(vFilter) = True Then
For Each oFolderItem In oFolderItems
If oFolderItem.Type <> "File folder" Then
Debug.Print oFolderItem.Path, oFolderItem.Name, _
oFolderItem.Size, oFolderItem.Type, oFolderItem.ModifyDate
''https://learn.microsoft.com/en-us/windows/win32/shell/folderitem-size
'Debug.Print oFolderItem.ExtendedProperty("type")
'Debug.Print oFolderItem.ExtendedProperty("owner")
'Debug.Print oFolderItem.ExtendedProperty("infotip")
'Debug.Print oFolderItem.ExtendedProperty("size")
Else
'Folders
If bProcessSubFolders = True Then
Call Shell_ListFilesInFolder(sPath & oFolderItem.Name, _
vFilter, bProcessSubFolders)
End If
End If
Next oFolderItem
Else
For Each oFolderItem In oFolderItems
If oFolderItem.Type <> "File folder" Then
If oFolderItem.Name Like vFilter Then
Debug.Print oFolderItem.Path, oFolderItem.Name, _
oFolderItem.Size, oFolderItem.Type, oFolderItem.ModifyDate
End If
Else
'Folders
If bProcessSubFolders = True Then
Call Shell_ListFilesInFolder(sPath & oFolderItem.Name, _
vFilter, bProcessSubFolders)
End If
End If
Next oFolderItem
End If
End If
End If
Error_Handler_Exit:
On Error Resume Next
Set oFolderItem = Nothing
Set oFolderItems = Nothing
Set oFolder = Nothing
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Shell_ListFilesInFolder" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Unzip a Zipped File/Folder
In this example I have not tried to implement any of the options, but check out the reference specified in the header if you wish to try and use them to control the progress dialog.
'---------------------------------------------------------------------------------------
' Procedure : Shell_UnZipFile
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Extract/Unzip the contents of a zip file to the specified folder.
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
' References: https://learn.microsoft.com/en-us/windows/win32/shell/folder-copyhere
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sZipFile : Path and filename of the zipe file to unzip
' sDestinationPath : Path where to extract the files to
'
' Usage:
' ~~~~~~
' Shell_UnZipFile("C:\Users\Dev\Downloads\Access_2.131.112.zip", "C:\Temp\Db")
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-05
'---------------------------------------------------------------------------------------
Public Sub Shell_UnZipFile(ByVal sZipFile, ByVal sDestinationPath)
On Error GoTo Error_Handler
#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Dim oFolderSrc As Shell32.Folder
Dim oFolderDest As Shell32.Folder
Dim oFolderSrcItems As Shell32.FolderItems
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Dim oFolderSrc As Object
Dim oFolderDest As Object
Dim oFolderSrcItems As Variant 'Must be Variant, not Object!
Set oShell = CreateObject("Shell.Application")
#End If
Set oFolderSrcItems = oShell.Namespace(sZipFile).Items()
If Not oFolderSrcItems Is Nothing Then
Set oFolderDest = oShell.Namespace(sDestinationPath)
If Not oFolderDest Is Nothing Then
If oFolderSrcItems.Count <> 0 Then
oFolderDest.CopyHere oFolderSrcItems ', vOptions
End If
End If
End If
Error_Handler_Exit:
On Error Resume Next
Set oFolderSrcItems = Nothing
Set oFolderDest = Nothing
Set oShell = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_UnZipFile" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
Extract a Single File from a Zipped File/Folder
'---------------------------------------------------------------------------------------
' Procedure : Shell_ExtractFileFromZip
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Extract a single file from a zip file
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sZipFile : File Path and Name of the Zip File
' sFileSubFolder : Subfolder within the zip file where the file is located
' enter "" if in the root folder
' sFileName : Name of the file to extract
' sDestinationPath : Path where the file should be extracted
'
' Output Variables:
' ~~~~~~~~~~~~~~~~
' Returns True/False (Boolean)
' True -> file extraction was successful
' False -> unable to extract file
'
' Usage:
' ~~~~~~
' Call Shell_ExtractFileFromZip("C:\Stats\AnnualReview.zip", "", "RawData_Q3.xlsx", "C:\Users\Daniel\Desktop\")
' Returns -> True
'
' Call Shell_ExtractFileFromZip("C:\Stats\AnnualReview.zip", "charting\Q3\", "profits.jpg", "C:\Users\Daniel\Desktop\")
' Returns -> True
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-04
'---------------------------------------------------------------------------------------
Function Shell_ExtractFileFromZip(ByVal sZipFile As String, _
ByVal sFileSubFolder As String, _
ByVal sFileName As String, _
ByVal sDestinationPath As String) As Boolean
On Error GoTo Error_Handler
'#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Dim oZipFolder As Shell32.folder
Dim oZipItem As Shell32.FolderItem
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Dim oZipFolder As Object
Dim oZipItem As Object
Set oShell = CreateObject("Shell.Application")
#End If
Dim sZipItemFullPath As String
Set oShell = CreateObject("Shell.Application")
'Set zipFile = sh.Namespace((zipPath))
Set oZipFolder = oShell.NameSpace(CVar(sZipFile))
If sFileSubFolder = "" Then
sZipItemFullPath = sFileName
Else
sZipItemFullPath = sFileSubFolder & "\" & sFileName
End If
Set oZipItem = oZipFolder.ParseName(sZipItemFullPath)
If Not oZipItem Is Nothing Then
oShell.NameSpace((sDestinationPath)).CopyHere oZipItem
Shell_ExtractFileFromZip = True
Else
Debug.Print "File not found: " & sZipItemFullPath
End If
Error_Handler_Exit:
On Error Resume Next
Set oZipItem = Nothing
Set oZipFolder = Nothing
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_ExtractFileFromZip" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Create a Zip File – Zip Folder or Files
'---------------------------------------------------------------------------------------
' Procedure : Shell_AddToZipFile
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Add items to a Zip file (create it if necessary)
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Early Binding -> Microsoft Shell Controls And Automation
' Late Binding -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sZipFile : File Path and Name of the Zip File
' sFolderOrFile : Folder or File to add to the Zip File
' bOverwriteZip : Whether to overwrite the Zip file if it already exists
' True => Overwrite, so create a new zip file
' False => do NOT overwrite the existing file, append to it instead
'
' Usage:
' ~~~~~~
' ? Shell_AddToZipFile("C:\Users\Dev\Desktop\Testing01.zip", "C:\temp\charts\")
' Returns -> True
'
' ? Shell_AddToZipFile("C:\Users\Dev\Desktop\Testing01.zip", "C:\temp\Book1.xls")
' Returns -> True
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2023-03-05
'---------------------------------------------------------------------------------------
Public Function Shell_AddToZipFile(ByVal sZipFile, ByVal sFolderOrFile As String, _
Optional bOverwriteZip As Boolean = False) As Boolean
On Error GoTo Error_Handler
'#Const Shell32_EarlyBind = False 'True => Early Binding / False => Late Binding
#If Shell32_EarlyBind = True Then
Dim oShell As Shell32.Shell
Dim oZipFolder As Object
Dim oItem As Object
Set oShell = New Shell32.Shell
#Else
Dim oShell As Object
Dim oZipFolder As Object
Dim oItem As Object
Set oShell = CreateObject("Shell.Application")
#End If
Dim FileNumber As Integer
Dim sPath As String
Dim sFileName As String
Dim sType As String
Dim lNoItems As Long
'Create the zip file, if it doesn't exist
If Not Shell_FileExist(sZipFile) Or bOverwriteZip Then
FileNumber = FreeFile
Open sZipFile For Output As #FileNumber
Print #FileNumber, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #FileNumber
End If
Set oZipFolder = oShell.Namespace((sZipFile))
If Not oZipFolder Is Nothing Then
sPath = Left(sFolderOrFile, InStrRev(sFolderOrFile, "\"))
sFileName = Right(sFolderOrFile, Len(sFolderOrFile) - InStrRev(sFolderOrFile, "\"))
If InStr(sFileName, ".") = 0 Then
Set oItem = oShell.Namespace((sFolderOrFile))
sType = oItem.Self.Type
lNoItems = oItem.Items.Count
Else
Set oItem = oShell.Namespace((sPath))
Set oItem = oItem.ParseName(sFileName)
sType = oItem.Type
lNoItems = 1
End If
If Not oItem Is Nothing Then
If sType = "File Folder" Then
oZipFolder.CopyHere oItem.Items
Else
oZipFolder.CopyHere (sFolderOrFile)
End If
Shell_AddToZipFile = True
End If
End If
Error_Handler_Exit:
On Error Resume Next
Set oItem = Nothing
Set oZipFolder = Nothing
Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Source: Shell_AddToZipFile" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
There’s actually a lot more that can be done with Shell.Applications! This was just a small taste, but I hope I’ve managed to demonstrate a little bit of how versatile Shell.Application can be to your programming toolbox.
OMG this is great! I’ve been struggling to unzip/zip for *hours* on a 64-bit machine.
Thank you!
You’re most welcome. I’m truly glad you found it useful!
Unfortunately Shell_AddToZipFile is creating a corrupt zip file.
What type of file(s) are you zipping? What mechanism are you using to unzip the file at the other end?
Very useful, just one question. In create a zipfile, why is freefile not defined? What should be the number of this variant?
FreeFile is a VBA function: https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/freefile-function so nothing to declare/define.
Thank you, works perfectly!
I have an issue with the following:-
Sub CreateZipFile(folderToZipPath As Variant, zippedFileFullName As Variant)
Dim ShellApp As Object
‘Create an empty zip file
Open zippedFileFullName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
‘Copy the files & folders into the zip file
Set ShellApp = CreateObject(“Shell.Application”)
ShellApp.Namespace(zippedFileFullName).CopyHere ShellApp.Namespace(folderToZipPath).Items
End Sub
The ‘folderToZipPath’ references a folder containing a .accdb Access database together with a sub folder containing pdf documents.
This works OK on my pc, but on another it crashes after creating the zip file. On examination, the zip file has no permissions, and therefore will not allow the copy operation to execute. Any idea how to force set the permissions to ‘full control’