So a Microsoft Excel workbook .xlsx or .xlsm is in fact a zipped file and here I give code that allows the unzipping and inspection of the contents therein. I have a class to give in this post but also use classes given in the previous two posts, so if you think code is missing then look to prior posts
Dependencies
The two other classes required to complete this project are the RecursiveXmlPrettifier class and the RecursiveExplorerWindows class. These classes allow us to explore all the sub directories in the unzipped folder as well as prettify any Xml files therein.
The two type library dependencies are Microsoft Scripting Runtime for file operations and Microsoft Shell Controls and Automation for (un)zipping a file.
With Thanks to Ron deBruin - NewZip
There is an absolute gem borrowed from Ron deBruin at https://www.rondebruin.nl which creates a new zip file directly from a sequence of bytes. Fantastic!
How to use this - instructions for demo
The code in the test module illustrate the two main methods on the WorkbookGuts class, open and close. But also given in the test code is logic to open up all the windows and also the prettify the xml files. Without the prettification of the xml files they would not be readable in Notepad, one would have to open them up in Visual Studio and say Format Document which would be a pain.
There is documentation for this directory structure at Microsoft's Open Xml SDK 2.5 for Office.
Future Posts
I will post further on this zip format. I will comment how I think it is quite complicated if not too complicated. I will also post on Microsoft's Open Xml SDK 2.5 for Office and contrast its complexity with the simplicity of VBA. As an epilogue to that series of posts, I will compare this serialization format with that of Google Sheets which seems tons simpler.
The WorkbookGuts class
Option Explicit
'*Tools->References
'* Microsoft Scripting Runtime C:\Windows\sysWOW64\scrrun.dll
'* Microsoft Shell Controls and Automation C:\Windows\sysWOW64\shell32.dll
Private mfso As New Scripting.FileSystemObject
Public bDebug As Boolean
Public bVerbose As Boolean
Friend Function ApplicationDirectory() As String
Dim sApplicationDirectory As String
sApplicationDirectory = mfso.BuildPath(Environ$("TMP"), "VBAEquivOfOpenXML")
If Not mfso.FolderExists(sApplicationDirectory) Then mfso.CreateFolder (sApplicationDirectory)
ApplicationDirectory = sApplicationDirectory
End Function
Friend Function ExtractFolder(ByVal sWookbookName As String) As String
If mfso.FileExists(sWookbookName) Then
Dim filWorkbook As Scripting.File
Set filWorkbook = mfso.GetFile(sWookbookName)
ExtractFolder = mfso.BuildPath(ApplicationDirectory, Split(filWorkbook.Name, ".")(0))
End If
End Function
Friend Function LeafName(ByVal sWookbookName As String) As String
If mfso.FileExists(sWookbookName) Then
Dim filWorkbook As Scripting.File
Set filWorkbook = mfso.GetFile(sWookbookName)
LeafName = filWorkbook.Name
End If
Debug.Assert VBA.InStr(1, LeafName, "\", vbTextCompare) = 0
End Function
Friend Function LeafNameToZip(ByVal sWookbookName As String) As String
Dim sLeafName As String
sLeafName = LeafName(sWookbookName)
LeafNameToZip = VBA.Replace(VBA.Replace(sLeafName, ".xlsm", ".zip"), ".xlsx", ".zip")
End Function
Public Sub CloseTheGutsOfTheWorbook(ByVal sWookbookName As String, Optional sNewWorkbookName As String = "")
On Error GoTo ErrHandler
If LenB(sNewWorkbookName) = 0 Then sNewWorkbookName = sWookbookName
If mfso.FileExists(sWookbookName) Then
Dim filWorkbook As Scripting.File
Set filWorkbook = mfso.GetFile(sWookbookName)
Dim sApplicationDirectory As String
sApplicationDirectory = ApplicationDirectory
Dim sWorkbookZip As String
sWorkbookZip = mfso.BuildPath(sApplicationDirectory, LeafNameToZip(sWookbookName))
With New Shell32.Shell
Dim sExtractFolder As String
sExtractFolder = mfso.BuildPath(sApplicationDirectory, Split(filWorkbook.Name, ".")(0))
If mfso.FileExists(sWorkbookZip) Then Call mfso.DeleteFile(sWorkbookZip, True)
NewZip sWorkbookZip
Debug.Assert mfso.FileExists(sWorkbookZip)
'Call mfso.CreateFile(sWorkbookZip)
Dim oExtractFolderNamespace As Shell32.Folder
Set oExtractFolderNamespace = .Namespace(sExtractFolder)
'.Namespace(sWorkbookZip).CopyHere .Namespace(sExtractFolder).Items
Dim oZippedFileNamespace As Shell32.Folder
Set oZippedFileNamespace = .Namespace(sWorkbookZip)
oZippedFileNamespace.CopyHere oExtractFolderNamespace.Items
'* above line is multi-threaded it seems, need to wait
While oZippedFileNamespace.Items.Count <> oExtractFolderNamespace.Items.Count
DoEvents
Application.Wait CDate(Now() + CDate("00:00:01"))
DoEvents
Wend
End With
'CopyFileEH sWorkbookZip, sNewWorkbookName
mfso.CopyFile sWorkbookZip, sNewWorkbookName
End If
SingleExit:
Exit Sub
ErrHandler:
If bDebug Then
Stop
Resume
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If
End Sub
'* https://www.rondebruin.nl/win/s7/win001.htm
'* With thanks to Ron deBruin @ https://www.rondebruin.nl
Private Sub NewZip(ByVal sPath As String)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Public Function OpenTheGutsOfTheWorbook(ByVal sWookbookName As String, ByVal oPrettifyXml As RecursiveXmlPrettifier) As String
On Error GoTo ErrHandler
If mfso.FileExists(sWookbookName) Then
Dim filWorkbook As Scripting.File
Set filWorkbook = mfso.GetFile(sWookbookName)
Dim sApplicationDirectory As String
sApplicationDirectory = ApplicationDirectory
Dim sWorkbookZip As String
sWorkbookZip = mfso.BuildPath(sApplicationDirectory, LeafNameToZip(sWookbookName))
mfso.CopyFile sWookbookName, sWorkbookZip
With New Shell32.Shell
'* Introduction to the Shell Namespace
'* https://msdn.microsoft.com/en-us/library/windows/desktop/cc144090(v=vs.85).aspx
Dim oFolder As Shell32.Folder
Set oFolder = .Namespace(sApplicationDirectory)
Dim oFolderItem As Shell32.FolderItem
Set oFolderItem = oFolder.ParseName(filWorkbook.Name)
Dim sExtractFolder As String
sExtractFolder = mfso.BuildPath(sApplicationDirectory, Split(filWorkbook.Name, ".")(0))
If mfso.FolderExists(sExtractFolder) Then Call mfso.DeleteFolder(sExtractFolder)
If Not mfso.FolderExists(sExtractFolder) Then CreateFolderMultipleAttempts sExtractFolder ' mfso.CreateFolder sExtractFolder
Debug.Assert mfso.FolderExists(sExtractFolder)
.Namespace(sExtractFolder).CopyHere .Namespace(sWorkbookZip).Items
OpenTheGutsOfTheWorbook = sExtractFolder '* so the caller can shell explorer too
If Not oPrettifyXml Is Nothing Then
oPrettifyXml.PrettyPrintAllInFolder sExtractFolder
End If
End With
End If
SingleExit:
Exit Function
ErrHandler:
If bDebug Then
Stop
Resume
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If
End Function
Function CreateFolderMultipleAttempts(ByVal sFolder As String)
On Error GoTo ErrHandler
Dim dtInterval As Date
dtInterval = Interval(1)
Const lMaxAttempts As Long = 3
Dim lAttempts As Long
lAttempts = 0
Retry:
On Error Resume Next
If lAttempts < lMaxAttempts Then
lAttempts = lAttempts + 1
If bVerbose Then Debug.Print "Attempting (" & lAttempts & " of " & lMaxAttempts & ") to call [" & TypeName(mfso) & "].CreateFolder"
'**********************************************************************************************************************************
'* CORE OPERATION
'**********************************************************************************************************************************
mfso.CreateFolder sFolder
'**********************************************************************************************************************************
'* END OF CORE OPERATION
'**********************************************************************************************************************************
End If
If Err.Number <> 0 Then
If lAttempts < lMaxAttempts Then
'* still have some goes left, report (of verbose) then wait
If bVerbose Then Debug.Print "(" & Err.Number & ") " & Err.Description & " whilst attempting to call [" & TypeName(mfso) & "].CreateFolder"
If dtInterval > 0 Then
If bVerbose Then Debug.Print "reattempting after interval " & VBA.FormatDateTime(dtInterval)
Application.Wait Now() + dtInterval
End If
Err.Clear
GoTo Retry
Else
'* no more attempts left, throw to caller
On Error GoTo 0
Err.Raise Err.Number, Err.Source, Err.Description
End If
End If
SingleExit:
Exit Function
ErrHandler:
If bDebug Then
Debug.Print "step-thru: (" & Err.Number & ") " & Err.Description & " whilst attempting to create folder '" & sFolder & "'"
Stop
Resume
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If
End Function
Private Function Interval(ByVal lIntervalSeconds As Long) As Date
Dim lHours As Long
lHours = lIntervalSeconds \ 3600
Dim lMinutes As Long
lMinutes = (lIntervalSeconds Mod 3600) \ 60
Dim lSeconds As Long
lSeconds = (lIntervalSeconds Mod 3600) Mod 60
Dim sInterval As String
sInterval = Right$("00" & lHours, 2) & ":" & Right$("00" & lMinutes, 2) & ":" & Right$("00" & lSeconds, 2)
Interval = CDate(sInterval)
End Function
The tstTestWorkbookGuts standard (test) module
Option Explicit
Option Private Module
'*Tools->References
' *** Microsoft Scripting Runtime
Private Const msBOOKNAME As String = "n:\WorkbookGuts\Book1.xlsx"
Private mfso As New Scripting.FileSystemObject
Sub TestOpenTheGutsOfTheWorbook()
Dim oGuts As WorkbookGuts
Set oGuts = New WorkbookGuts
oGuts.bDebug = True
Dim oRecursiveExplorerWindows As RecursiveExplorerWindows
Set oRecursiveExplorerWindows = New RecursiveExplorerWindows
Debug.Assert oGuts.ExtractFolder(msBOOKNAME) = Environ$("userprofile") & "\AppData\Local\Temp\VBAEquivOfOpenXML\Book1"
'* close off windows that will prevent the extract operation
oRecursiveExplorerWindows.CloseFolderAndAllSubfolder oGuts.ExtractFolder(msBOOKNAME)
Dim oRecursiveXmlPrettifier As RecursiveXmlPrettifier
Set oRecursiveXmlPrettifier = New RecursiveXmlPrettifier
Dim sTempDir As String
sTempDir = oGuts.OpenTheGutsOfTheWorbook(msBOOKNAME, oRecursiveXmlPrettifier)
oRecursiveExplorerWindows.OpenFolderAndAllSubfolder sTempDir
Debug.Print "TestOpenTheGutsOfTheWorbook"
End Sub
Sub TestCloseTheGutsOfTheWorbook()
Dim oGuts As WorkbookGuts
Set oGuts = New WorkbookGuts
Const sRETURNED As String = "Book1 returned.xlsx"
Dim sReturnedWorkbook As String
sReturnedWorkbook = VBA.Replace(msBOOKNAME, "Book1.xlsx", sRETURNED)
On Error Resume Next
Dim wbReturnedWorkbook As Excel.Workbook
Set wbReturnedWorkbook = Application.Workbooks.Item(sRETURNED)
On Error GoTo 0
Debug.Assert wbReturnedWorkbook Is Nothing '<-- returned workbook should be closed otherwise permission denied
oGuts.bDebug = True
oGuts.CloseTheGutsOfTheWorbook msBOOKNAME, sReturnedWorkbook
Debug.Print "TestCloseTheGutsOfTheWorbook"
End Sub
No comments:
Post a Comment