In a previous post I briefly explained how you can compile the free zlib library with Visual 2013 Studio and produce a 32 and a 64 bits dll that you can then use in VBA (Word, Excel, Access, etc…). If you follow this link to the article, you can even download the binaries I baked.
However, to use these dlls in a real world project, we need to wrap them in some 32/64 bits VBA code.
Inspired by samples I found on the web, here a quickly reusable module for your VBA projects.
Look at the TestXXXX procedures (change the pathes and filenames, of course, and execute them in the immediate window) for some samples.
Enjoy!
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
Option Compare Database ' Only valid in Access, delete this line in other environments Option Explicit #If Win64 Then Private Declare PtrSafe Function compress Lib "zlibwapi64.dll" _ (ByVal sDest As String, ByRef lDestLen As Long, _ ByVal sSource As String, ByVal lSrcLen As Long) As Long Private Declare PtrSafe Function compress2 Lib "zlibwapi64.dll" _ (ByVal sDest As String, ByRef lDestLen As Long, _ ByVal sSource As String, ByVal lSrcLen As Long, _ ByVal lLevel As Long) As Long Private Declare PtrSafe Function uncompress Lib "zlibwapi64.dll" _ (ByVal sDest As String, ByRef lDestLen As Long, _ ByVal sSource As String, ByVal lSrcLen As Long) As Long Private Declare PtrSafe Function compressBound Lib "zlibwapi64.dll" _ (ByVal lSourceLen As Long) As Long Private Declare PtrSafe Function zlibCompileFlags Lib "zlibwapi64.dll" () As Long #Else Private Declare Function compress Lib "zlibwapi32.dll" _ (ByVal sDest As String, ByRef lDestLen As Long, _ ByVal sSource As String, ByVal lSrcLen As Long) As Long Private Declare Function compress2 Lib "zlibwapi32.dll" _ (ByVal sDest As String, ByRef lDestLen As Long, _ ByVal sSource As String, ByVal lSrcLen As Long, _ ByVal lLevel As Long) As Long Private Declare Function uncompress Lib "zlibwapi32.dll" _ (ByVal sDest As String, ByRef lDestLen As Long, _ ByVal sSource As String, ByVal lSrcLen As Long) As Long Private Declare Function compressBound Lib "zlibwapi32.dll" _ (ByVal lSourceLen As Long) As Long Private Declare Function zlibCompileFlags Lib "zlibwapi32.dll" () As Long #End If Private Const Z_OK As Long = 0& Private Const Z_STREAM_END As Long = 1& Private Const Z_NEED_DICT As Long = 2& Private Const Z_ERRNO As Long = -1& Private Const Z_STREAM_ERROR As Long = -2& Private Const Z_DATA_ERROR As Long = -3& Private Const Z_MEM_ERROR As Long = -4& Private Const Z_BUF_ERROR As Long = -5& Private Const Z_VERSION_ERROR As Long = -6& 'Error context Private mlErr As Long Private msErr As String Private msErrCtx As String Private Sub ClearErr() mlErr = 0& msErr = "" End Sub Private Sub SetErr(ByVal psErrCtx As String, ByVal plErr As Long, ByVal psErr As String) msErrCtx = psErrCtx mlErr = plErr msErr = psErr End Sub Public Function ZipLastErr() As Long ZipLastErr = mlErr End Function Public Function ZipLastErrDesc() As String ZipLastErrDesc = msErr End Function Public Function ZipLastErrCtx() As String ZipLastErrCtx = msErrCtx End Function ' Compresses a string with the Zlib compress routine. Sticks the number of ' characters on the front of the string to aid with decompressing the data ' later. Public Function CompressString(ByVal psSource As String, Optional ByVal pvLevel As Variant) As String Dim sCompressed As String Dim lRet As Long Dim lSrcLen As Long Dim lCompLen As Long Const PROC_CONTEXT As String = "CompressString" On Error GoTo CompressString_Err ClearErr lSrcLen = Len(psSource) If lSrcLen = 0 Then Exit Function lCompLen = compressBound(lSrcLen) sCompressed = Space$(CLng(lCompLen)) If IsMissing(pvLevel) Then lRet = compress(sCompressed, lCompLen, psSource, lSrcLen) Else lRet = compress2(sCompressed, lCompLen, psSource, lSrcLen, CLng(pvLevel)) End If Select Case lRet Case Z_OK sCompressed = Left(sCompressed, CLng(lCompLen)) CompressString = lSrcLen & ":" & sCompressed Case Z_MEM_ERROR SetErr PROC_CONTEXT, lRet, "Out of memory when compressing string" Case Z_BUF_ERROR SetErr PROC_CONTEXT, lRet, "Output buffer too small" Case Else SetErr PROC_CONTEXT, lRet, "An unexpected error occurred while compressing the string" End Select CompressString_Exit: Exit Function CompressString_Err: SetErr PROC_CONTEXT, Err.Number, Err.Description Resume CompressString_Exit End Function ' Uncompresses a string with the Zlib uncompress routine that has been previously ' compressed with the CompressString function in this module as it relies on the ' string starting with the number of characters required to output the string. Public Function UncompressString(ByVal psCompressed As String) As String Dim sUncompressed As String Dim lUncompLen As Long Dim sBuffer As String Dim lBufLen As Long Dim lColPos As Long Dim lRet As Long Const PROC_CONTEXT As String = "UncompressString" If Len(psCompressed) = 0 Then Exit Function On Error GoTo UncompressString_Err ClearErr lUncompLen = Val(psCompressed) sUncompressed = Space$(CLng(lUncompLen)) lColPos = Len(CStr(lUncompLen)) + 1 sBuffer = Mid(psCompressed, lColPos + 1) lBufLen = Len(sBuffer) lRet = uncompress(sUncompressed, lUncompLen, sBuffer, lBufLen) Select Case lRet Case Z_OK UncompressString = sUncompressed Case Z_MEM_ERROR SetErr PROC_CONTEXT, lRet, "Out of memory while uncompressing string" Case Z_BUF_ERROR SetErr PROC_CONTEXT, lRet, "Out of buffer space while uncompressing string" Case Z_DATA_ERROR SetErr PROC_CONTEXT, lRet, "Data to uncompress is corrupt" Case Else SetErr PROC_CONTEXT, lRet, "An unexpected error occurred while compressing the string" End Select UncompressString_Exit: Exit Function UncompressString_Err: SetErr PROC_CONTEXT, Err.Number, Err.Description Resume UncompressString_Exit End Function Public Sub TestCompress() Dim sInitial As String Dim sTest As String Dim sStrongComp As String sInitial = InputBox$("Gimme a string ta compress", "Test zlibwapi", "The freakin quick brown fox jumps over the frackin lazy dog.") sTest = CompressString(sInitial) sStrongComp = CompressString(sInitial, 9) Debug.Print "Compressed (len="; Len(sTest); ") ["; sTest; "]" Debug.Print "Strongly compressed (len="; Len(sStrongComp); "): ["; sStrongComp; "]" sTest = UncompressString(sTest) Debug.Print "Uncompressed: ["; sTest; "]" sTest = UncompressString(sStrongComp) Debug.Print "Strongly Uncompressed: ["; sTest; "]" Dim lFlags As Long Dim lIntSize As Long Dim lLongSize As Long Dim lVoidPfSize As Long lFlags = zlibCompileFlags() lIntSize = lFlags And 3& lIntSize = (2 ^ (4 + lIntSize)) Mod &H80 lLongSize = (lFlags And &HC) \ &H4 lLongSize = (2 ^ (4 + lLongSize)) Mod &H80 lVoidPfSize = (lFlags And &HC0) \ &H40 lVoidPfSize = (2 ^ (4 + lVoidPfSize)) Mod &H80 Debug.Print "Flags="; Hex$(lFlags) Debug.Print "Sizeof uInt="; lIntSize Debug.Print "Sizeof ulong="; lLongSize Debug.Print "Sizeof pvoid="; lVoidPfSize End Sub 'here's how we can simply compress and decompress a file (all in memory, using string buffer) Public Sub TestCompress2() Dim sTest As String Dim sStrongComp As String Dim fh As Integer fh = FreeFile Open "c:\blabla\mydatabase.accdb" For Binary As #fh sTest = String$(LOF(fh), " ") Get #fh, , sTest Close fh sStrongComp = CompressString(sTest, 9) Debug.Print "Strongly compressed: ["; Left$(sStrongComp, 20); "]" sTest = UncompressString(sStrongComp) Debug.Print "Len compressed="; Len(sStrongComp); ", Len uncompressed="; Len(sTest) fh = FreeFile Open "c:\blabla\mydatabase-cloned.accdb" For Binary As #fh Put #fh, , sTest Close fh Debug.Print "Uncompressed file saved" End Sub |
Recent Comments