├── .gitattributes ├── .github └── FUNDING.yml ├── LICENSE ├── README.md ├── VBA MemoryTools_Demo.xlsm └── src ├── Demo ├── DemoClass.cls └── DemoLibMemory.bas ├── LibMemory.bas └── Test └── TestLibMemory.bas /.gitattributes: -------------------------------------------------------------------------------- 1 | *.bas eol=crlf linguist-language=VBA 2 | *.cls eol=crlf linguist-language=VBA -------------------------------------------------------------------------------- /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: cristianbuse 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Ion Cristian Buse 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # VBA-MemoryTools [![Mentioned in Awesome VBA](https://awesome.re/mentioned-badge.svg)](https://github.com/sancarn/awesome-vba) 2 | Native memory manipulation in VBA. 3 | 4 | There is an issue with the speed of API calls in **VBA7**. This is very well tested and explained in [this Code Review question](https://codereview.stackexchange.com/questions/270258/evaluate-performance-of-dll-calls-from-vba). 5 | 6 | This library overcomes the speed issues for reading and writing from and into memory by using a native approach. 7 | 8 | This library exposes some useful utilities and wrappers to make it easier to manipulate memory. For **Mac**, **TwinBasic** and **VBA6** (and prior) this library simply uses wrapped API calls as there is no speed benefit in using the native approach. 9 | 10 | Copying a byte for 10,000 times on Windows with VBA7 x64 using ```RtlMoveMemory``` API takes around 10 seconds while the native struct approach takes only around 8 milliseconds for the same number of iterations. So, the speed gain is over 1000x in some cases. 11 | 12 | ## Implementation 13 | 14 | **Prior to 24-Nov-2023** (see [5058e3333c](https://github.com/cristianbuse/VBA-MemoryTools/tree/5058e3333c5695291984cdfd2750e3ff61f27823)) this library used a 'Variant ByRef' approach - see related [CR question](https://codereview.stackexchange.com/questions/252659/fast-native-memory-manipulation-in-vba) which describes the technique (initially used [here](https://codereview.stackexchange.com/a/249125/227582)). 15 | 16 | **Starting 24-Nov-2023** this library uses a ```MEMORY_ACCESSOR``` type/struct that allows acces to memory via UDT arrays with faster speeds (x2 at least). 17 | 18 | A single CopyMemory API call is used when initializing the base ```MEMORY_ACCESSOR``` structure (see ```InitMemoryAccessor```). Subsequent usage relies on native VBA calls only. 19 | The ```MEMORY_ACCESSOR``` contains a ```SAFEARRAY``` structure and an ```ArrayAccessor``` structure. Once initialized, all the arrays in the ```ArrayAccessor``` will point to the data defined in the corresponding ```SAFEARRAY``` structure, thus adapting in real time to changes of address, number of elements or element size. All arrays are locked and are safe i.e. no memory pointed by these arrays gets deallocated. 20 | 21 | ## Use 22 | - ```MemCopy``` - a faster alternative to ```CopyMemory``` (for VBA7) without API calls on Windows. Only defaults to ```CopyMemory``` when the API is faster. 23 | - ```MemFill``` - a faster alternative to ```FillMemory``` (for VBA7) without API calls on Windows. Uses a fake BSTR and a call to ```MidB$``` to fill memory up to a certain size. Only defaults to ```FillMemory``` when the API is faster. 24 | - ```MemZero``` - wrapper for ```MemFill``` with byte value set to zero. 25 | 26 | 10 parametric properties (Get/Let) are exposed: 27 | 01. ```MemByte``` 28 | 02. ```MemInt``` 29 | 03. ```MemLong``` 30 | 04. ```MemLongPtr``` 31 | 05. ```MemLongLong``` (x64 only) 32 | 06. ```MemBool``` 33 | 07. ```MemSng``` 34 | 08. ```MemCur``` 35 | 09. ```MemDate``` 36 | 10. ```MemDbl``` 37 | 38 | Persistent memory allocation/deallocation: 39 | - ```MemAlloc``` 40 | - ```MemFree``` 41 | 42 | Memory allocated with ```MemAlloc``` is deallocated automatically on state loss or by calling ```MemFree``` using the original pointer returned by ```MemAlloc``` 43 | 44 | A few other utilities: 45 | - ```GetDefaultInterface``` 46 | - ```MemObj``` (dereferences a pointer and returns an Object) 47 | - ```UnsignedAddition``` 48 | - ```VarPtrArr``` (```VarPtr``` for arrays) 49 | - ```ArrPtr``` (as ```ObjPtr``` is for objects and ```StrPtr``` is for strings) - returns the pointer to the underlying SAFEARRAY structure 50 | - ```CloneParamArray``` - copies a param array to another array of Variants while preserving ByRef elements 51 | - ```GetArrayByRef``` - returns the input array wrapped in a ByRef Variant without copying the array 52 | - ```StringToIntegers``` - copies the memory of a String to an Array of Integers 53 | - ```IntegersToString``` - copies the memory of an Array of Integers to a String 54 | - ```EmptyArray``` - returns an empty array of the requested size and data type 55 | - ```UpdateLBound``` - changes the Lower Bound for a given array's dimension 56 | 57 | ## Class Instance Redirection 58 | 59 | Class instance redirection is supported. This allows Private Class Initializers thus achieving true immutabilty. 60 | Simply call the ```RedirectInstance``` method within a ```Private Function``` of any VB class to gain access to other instances of the same class. 61 | Related [Code Review question](https://codereview.stackexchange.com/questions/253233/private-vba-class-initializer-called-from-factory-2). 62 | 63 | See ```DemoInstanceRedirection``` method in the Demo module. 64 | 65 | ## Installation 66 | Just import the following code modules in your VBA Project: 67 | * [**LibMemory.bas**](https://github.com/cristianbuse/VBA-MemoryTools/blob/master/src/LibMemory.bas) 68 | 69 | ## Demo 70 | Import the following code modules from the [demo folder](https://github.com/cristianbuse/VBA-MemoryTools/blob/master/src/Demo) in your VBA Project: 71 | * [DemoLibMemory.bas](https://github.com/cristianbuse/VBA-MemoryTools/blob/master/src/Demo/DemoLibMemory.bas) - run ```DemoMain``` 72 | * [DemoClass](https://github.com/cristianbuse/VBA-MemoryTools/blob/master/src/Demo/DemoClass.cls) 73 | 74 | ## Testing 75 | Just import [TestLibMemory.bas](https://github.com/cristianbuse/VBA-MemoryTools/blob/master/src/Test/TestLibMemory.bas) module and run method ```RunAllTests```. On failure, execution will stop on the first failed Assert. 76 | 77 | Please [raise an issue](https://github.com/cristianbuse/VBA-MemoryTools/issues/new) if any test is failing. 78 | 79 | ## License 80 | MIT License 81 | 82 | Copyright (c) 2020 Ion Cristian Buse 83 | 84 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 85 | 86 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 87 | 88 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 89 | -------------------------------------------------------------------------------- /VBA MemoryTools_Demo.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cristianbuse/VBA-MemoryTools/56503b6366cc3f12192082d206583bfae63c32b0/VBA MemoryTools_Demo.xlsm -------------------------------------------------------------------------------- /src/Demo/DemoClass.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "DemoClass" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | '@PredeclaredId 11 | Option Explicit 12 | 13 | Private m_id As Long 14 | 15 | Public Function Factory(ByVal newID As Long) As DemoClass 16 | Dim c As New DemoClass 17 | Init c, newID 18 | Set Factory = c 19 | End Function 20 | 21 | Private Function Init(ByVal c As DemoClass, ByVal newID As Long) As Boolean 22 | RedirectInstance Init, VarPtr(Init), Me, c 23 | m_id = newID 24 | End Function 25 | 26 | Public Function Factory2(ByVal newID As Long) As DemoClass 27 | Dim c As New DemoClass 28 | ' 29 | c.Init2 newID 30 | Set Factory2 = c 31 | End Function 32 | Public Function Init2(ByVal newID As Long) As DemoClass 33 | m_id = newID 34 | End Function 35 | 36 | Public Property Get ID() As Long 37 | ID = m_id 38 | End Property 39 | -------------------------------------------------------------------------------- /src/Demo/DemoLibMemory.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "DemoLibMemory" 2 | Option Explicit 3 | Option Private Module 4 | 5 | #If Mac Then 6 | #If VBA7 Then 7 | Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr 8 | Private Declare PtrSafe Function FillMemory Lib "/usr/lib/libc.dylib" Alias "memset" (Destination As Any, ByVal Fill As Byte, ByVal Length As LongPtr) As LongPtr 9 | #Else 10 | Private Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long 11 | Private Declare Function FillMemory Lib "/usr/lib/libc.dylib" Alias "memset" (Destination As Any, ByVal Fill As Byte, ByVal Length As Long) As Long 12 | #End If 13 | #Else 'Windows 14 | 'https://msdn.microsoft.com/en-us/library/mt723419(v=vs.85).aspx 15 | #If VBA7 Then 16 | Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr) 17 | Private Declare PtrSafe Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As LongPtr, ByVal Fill As Byte) 18 | #Else 19 | Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) 20 | Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte) 21 | #End If 22 | #End If 23 | 24 | Sub DemoMain() 25 | Dim s As String: s = String$(13, "-") 26 | Debug.Print String(26, "-") & " Speed (seconds)" & String(27, "-") 27 | Debug.Print AlignCenter("Data Type"), AlignCenter("Iterations"), AlignCenter("By Ref") _ 28 | , AlignCenter("CopyMemory"), AlignCenter("Notes") 29 | Debug.Print AlignCenter("(To copy)"), AlignCenter("(Count)") _ 30 | , AlignCenter("(This Lib)"), AlignCenter("(DLL Export)") 31 | Debug.Print s, s, s, s, s 32 | DemoMemByteSpeed 33 | DemoMemIntSpeed 34 | DemoMemLongSpeed 35 | DemoMemLongPtrSpeed 36 | DemoMemObjectSpeed 37 | Debug.Print String(21, "-") & " Redirection " & String(21, "-") 38 | DemoInstanceRedirection 39 | Debug.Print String(37, "-") & " MemCopy " & String(37, "-") 40 | DemoMemCopySpeed 41 | Debug.Print String(30, "-") & " MemFill " & String(30, "-") 42 | DemoMemFillSpeed 43 | End Sub 44 | 45 | Private Function AlignRight(ByRef s As String, Optional ByVal size As Long = 13) As String 46 | AlignRight = Right$(Space$(size) & s, size) 47 | End Function 48 | Private Function AlignCenter(ByRef s As String, Optional ByVal size As Long = 13) As String 49 | Dim i As Long: i = size - Len(s) 50 | If i < 1 Then 51 | AlignCenter = s 52 | Else 53 | AlignCenter = Space$(i \ 2) & s & Space$(i / 2) 54 | End If 55 | End Function 56 | 57 | Private Sub DemoInstanceRedirection() 58 | Const loopsCount As Long = 100000 59 | Dim i As Long 60 | Dim t As Double 61 | ' 62 | Debug.Print Format$(loopsCount, "#,##0") & " times" 63 | t = Timer 64 | For i = 1 To loopsCount 65 | Debug.Assert DemoClass.Factory2(i).ID = i 66 | Next i 67 | Debug.Print "Public Init (seconds): " & VBA.Round(Timer - t, 3) 68 | ' 69 | t = Timer 70 | For i = 1 To loopsCount 71 | Debug.Assert DemoClass.Factory(i).ID = i 72 | Next i 73 | Debug.Print "Private Init (seconds): " & VBA.Round(Timer - t, 3) 74 | End Sub 75 | 76 | Private Sub DemoMemByteSpeed() 77 | Dim x1 As Byte: x1 = 1 78 | Dim x2 As Byte: x2 = 2 79 | Dim i As Long 80 | Dim t As Double 81 | Dim slowFactor As Long 82 | Dim res1 As Double 83 | Dim res2 As Double 84 | Const iterations As Long = 1000000 85 | Dim sp As String: sp = Space$(13) 86 | ' 87 | t = Timer 88 | For i = 1 To iterations 89 | MemByte(VarPtr(x1)) = MemByte(VarPtr(x2)) 90 | Next i 91 | res1 = Round(Timer - t, 3) 92 | ' 93 | slowFactor = 10000 'In case API call is too slow 94 | Do 95 | t = Timer 96 | For i = 1 To iterations \ slowFactor 97 | CopyMemory x1, x2, 1 98 | Next i 99 | res2 = Round(Timer - t, 3) 100 | If res2 < 0.1 Then 101 | slowFactor = slowFactor \ 10 102 | Else 103 | Exit Do 104 | End If 105 | Loop Until slowFactor = 0 106 | If slowFactor = 0 Then slowFactor = 1 'For IIf (Div by Zero) 107 | ' 108 | Debug.Print TypeName(x1), AlignRight(Format$(iterations, "#,##0")) _ 109 | , AlignRight(Format$(res1, "#,##0.000")) _ 110 | , AlignRight(Format$(res2 * slowFactor, "#,##0.000")) _ 111 | , IIf(slowFactor > 1, "(extrapolated from " _ 112 | & Format$(iterations \ slowFactor, "#,##0") _ 113 | & " iterations that took " & res2 & " seconds)", "") 114 | DoEvents 115 | End Sub 116 | 117 | Private Sub DemoMemIntSpeed() 118 | Dim x1 As Integer: x1 = 11111 119 | Dim x2 As Integer: x2 = 22222 120 | Dim i As Long 121 | Dim t As Double 122 | Dim slowFactor As Long 123 | Dim res1 As Double 124 | Dim res2 As Double 125 | Const iterations As Long = 1000000 126 | ' 127 | t = Timer 128 | For i = 1 To iterations 129 | MemInt(VarPtr(x1)) = MemInt(VarPtr(x2)) 130 | Next i 131 | res1 = Round(Timer - t, 3) 132 | ' 133 | slowFactor = 10000 'In case API call is too slow 134 | Do 135 | t = Timer 136 | For i = 1 To iterations \ slowFactor 137 | CopyMemory x1, x2, 2 138 | Next i 139 | res2 = Round(Timer - t, 3) 140 | If res2 < 0.1 Then 141 | slowFactor = slowFactor \ 10 142 | Else 143 | Exit Do 144 | End If 145 | Loop Until slowFactor = 0 146 | If slowFactor = 0 Then slowFactor = 1 'For IIf (Div by Zero) 147 | ' 148 | Debug.Print TypeName(x1), AlignRight(Format$(iterations, "#,##0")) _ 149 | , AlignRight(Format$(res1, "#,##0.000")) _ 150 | , AlignRight(Format$(res2 * slowFactor, "#,##0.000")) _ 151 | , IIf(slowFactor > 1, "(extrapolated from " _ 152 | & Format$(iterations \ slowFactor, "#,##0") _ 153 | & " iterations that took " & res2 & " seconds)", "") 154 | DoEvents 155 | End Sub 156 | 157 | Private Sub DemoMemLongSpeed() 158 | Dim x1 As Long: x1 = 111111111 159 | Dim x2 As Long: x2 = 222222222 160 | Dim i As Long 161 | Dim t As Double 162 | Dim slowFactor As Long 163 | Dim res1 As Double 164 | Dim res2 As Double 165 | Const iterations As Long = 1000000 166 | ' 167 | t = Timer 168 | For i = 1 To iterations 169 | MemLong(VarPtr(x1)) = MemLong(VarPtr(x2)) 170 | Next i 171 | res1 = Round(Timer - t, 3) 172 | ' 173 | slowFactor = 10000 'In case API call is too slow 174 | Do 175 | t = Timer 176 | For i = 1 To iterations \ slowFactor 177 | CopyMemory x1, x2, 4 178 | Next i 179 | res2 = Round(Timer - t, 3) 180 | If res2 < 0.1 Then 181 | slowFactor = slowFactor \ 10 182 | Else 183 | Exit Do 184 | End If 185 | Loop Until slowFactor = 0 186 | If slowFactor = 0 Then slowFactor = 1 'For IIf (Div by Zero) 187 | ' 188 | Debug.Print TypeName(x1), AlignRight(Format$(iterations, "#,##0")) _ 189 | , AlignRight(Format$(res1, "#,##0.000")) _ 190 | , AlignRight(Format$(res2 * slowFactor, "#,##0.000")) _ 191 | , IIf(slowFactor > 1, "(extrapolated from " _ 192 | & Format$(iterations \ slowFactor, "#,##0") _ 193 | & " iterations that took " & res2 & " seconds)", "") 194 | DoEvents 195 | End Sub 196 | 197 | Private Sub DemoMemLongPtrSpeed() 198 | #If Win64 Then 199 | Dim x1 As LongLong: x1 = 111111111111111^ 200 | Dim x2 As LongLong: x2 = 111111111111112^ 201 | #Else 202 | Dim x1 As Long: x1 = 111111111 203 | Dim x2 As Long: x2 = 222222222 204 | #End If 205 | Dim i As Long 206 | Dim t As Double 207 | Dim slowFactor As Long 208 | Dim res1 As Double 209 | Dim res2 As Double 210 | Const iterations As Long = 1000000 211 | ' 212 | t = Timer 213 | For i = 1 To iterations 214 | MemLongPtr(VarPtr(x1)) = MemLongPtr(VarPtr(x2)) 215 | Next i 216 | res1 = Round(Timer - t, 3) 217 | ' 218 | slowFactor = 10000 'In case API call is too slow 219 | Do 220 | t = Timer 221 | For i = 1 To iterations \ slowFactor 222 | CopyMemory x1, x2, PTR_SIZE 223 | Next i 224 | res2 = Round(Timer - t, 3) 225 | If res2 < 0.1 Then 226 | slowFactor = slowFactor \ 10 227 | Else 228 | Exit Do 229 | End If 230 | Loop Until slowFactor = 0 231 | If slowFactor = 0 Then slowFactor = 1 'For IIf (Div by Zero) 232 | ' 233 | Debug.Print TypeName(x1), AlignRight(Format$(iterations, "#,##0")) _ 234 | , AlignRight(Format$(res1, "#,##0.000")) _ 235 | , AlignRight(Format$(res2 * slowFactor, "#,##0.000")) _ 236 | , IIf(slowFactor > 1, "(extrapolated from " _ 237 | & Format$(iterations \ slowFactor, "#,##0") _ 238 | & " iterations that took " & res2 & " seconds)", "") 239 | DoEvents 240 | End Sub 241 | 242 | Private Sub DemoMemObjectSpeed() 243 | Dim i As Long 244 | Dim t As Double 245 | Dim d As DemoClass: Set d = New DemoClass 246 | Dim obj As Object 247 | #If Win64 Then 248 | Dim ptr As LongLong 249 | #Else 250 | Dim ptr As Long 251 | #End If 252 | Const iterations As Long = 1000000 253 | ' 254 | ptr = ObjPtr(d) 255 | t = Timer 256 | For i = 1 To iterations 257 | Set obj = MemObj(ptr) 258 | Next i 259 | Debug.Print 260 | Debug.Print "Dereferenced an Object " & Format$(iterations, "#,##0") _ 261 | & " times in " & Round(Timer - t, 3) & " seconds" 262 | DoEvents 263 | End Sub 264 | 265 | Private Sub DemoMemCopySpeed() 266 | Dim t As Double 267 | Dim a1() As Byte 268 | Dim a2() As Byte 269 | Dim size As Long 270 | Dim iterations As Long 271 | Dim i As Long 272 | Dim src As LongPtr 273 | Dim dest As LongPtr 274 | Dim res1 As Double 275 | Dim res2 As Double 276 | Dim slowFactor As Long 277 | Dim s As String: s = String$(13, "-") 278 | ' 279 | size = 2 280 | iterations = 2 ^ 21 281 | Debug.Print AlignCenter("Size"), AlignCenter("Iterations"), AlignCenter("MemCopy") _ 282 | , AlignCenter("CopyMemory"), AlignCenter("Notes") 283 | Debug.Print AlignCenter("(Bytes)"), AlignCenter("(Count)"), AlignCenter("(ACCESSOR)") _ 284 | , AlignCenter("(DLL export)") 285 | Debug.Print s, s, s, s, s 286 | Do 287 | ReDim a1(0 To size - 1) 288 | ReDim a2(0 To size - 1) 289 | ' 290 | src = VarPtr(a2(0)) 291 | dest = VarPtr(a1(0)) 292 | ' 293 | t = Timer 294 | For i = 1 To iterations 295 | MemCopy dest, src, size 296 | Next i 297 | res1 = Round(Timer - t, 3) 298 | ' 299 | slowFactor = 10000 'In case API call is too slow 300 | Do 301 | t = Timer 302 | For i = 1 To iterations \ slowFactor 303 | CopyMemory ByVal dest, ByVal src, size 304 | Next i 305 | res2 = Round(Timer - t, 3) 306 | If res2 < 0.1 Then 307 | slowFactor = slowFactor \ 10 308 | Else 309 | Exit Do 310 | End If 311 | Loop Until slowFactor = 0 312 | If slowFactor = 0 Then slowFactor = 1 'For IIf (Div by Zero) 313 | ' 314 | Debug.Print AlignRight(Format$(size, "#,##0")) _ 315 | , AlignRight(Format$(iterations, "#,##0")) _ 316 | , AlignRight(Format$(res1, "#,##0.000")) _ 317 | , AlignRight(Format$(res2 * slowFactor, "#,##0.000")) _ 318 | , IIf(slowFactor > 1, "(extrapolated from " _ 319 | & Format$(iterations \ slowFactor, "#,##0") _ 320 | & " iterations that took " & res2 & " seconds)", "") 321 | ' 322 | Const maxLong As Long = 2147483647 323 | If CDbl(size) * 2 > maxLong Then 324 | If CDbl(size) * 2 - 1 > maxLong Then 325 | iterations = 2 326 | Else 327 | size = CDbl(size) * 2 - 1 328 | End If 329 | Else 330 | size = size * 2 331 | End If 332 | iterations = iterations / 1.6 333 | DoEvents 334 | Loop Until iterations = 1 335 | End Sub 336 | 337 | Private Sub DemoMemFillSpeed() 338 | Dim t As Double 339 | Dim a() As Byte 340 | Dim size As Long 341 | Dim iterations As Long 342 | Dim i As Long 343 | Dim dest As LongPtr 344 | Dim res1 As Double 345 | Dim res2 As Double 346 | Dim slowFactor As Long 347 | Dim s As String: s = String$(13, "-") 348 | Const b As Byte = 255 349 | ' 350 | size = 2 351 | iterations = 2 ^ 21 352 | Debug.Print AlignCenter("Size"), AlignCenter("Iterations"), AlignCenter("MemFill") _ 353 | , AlignCenter("FillMemory"), AlignCenter("Notes") 354 | Debug.Print AlignCenter("(Bytes)"), AlignCenter("(Count)") _ 355 | , AlignCenter("MidB-MemCopy"), AlignCenter("(DLL export)") 356 | Debug.Print s, s, s, s, s 357 | Do 358 | ReDim a(0 To size - 1) 359 | ' 360 | dest = VarPtr(a(0)) 361 | ' 362 | t = Timer 363 | For i = 1 To iterations 364 | MemFill dest, size, b 365 | Next i 366 | res1 = Round(Timer - t, 3) 367 | ' 368 | slowFactor = 10000 'In case API call is too slow 369 | Do 370 | t = Timer 371 | For i = 1 To iterations \ slowFactor 372 | #If Mac Then 373 | FillMemory ByVal dest, b, size 374 | #Else 375 | FillMemory ByVal dest, size, b 376 | #End If 377 | Next i 378 | res2 = Round(Timer - t, 3) 379 | If res2 < 0.1 Then 380 | slowFactor = slowFactor \ 10 381 | Else 382 | Exit Do 383 | End If 384 | Loop Until slowFactor = 0 385 | If slowFactor = 0 Then slowFactor = 1 'For IIf (Div by Zero) 386 | ' 387 | Debug.Print AlignRight(Format$(size, "#,##0")) _ 388 | , AlignRight(Format$(iterations, "#,##0")) _ 389 | , AlignRight(Format$(res1, "#,##0.000")) _ 390 | , AlignRight(Format$(res2 * slowFactor, "#,##0.000")) _ 391 | , IIf(slowFactor > 1, "(extrapolated from " _ 392 | & Format$(iterations \ slowFactor, "#,##0") _ 393 | & " iterations that took " & res2 & " seconds)", "") 394 | ' 395 | Const maxLong As Long = 2147483647 396 | If CDbl(size) * 2 > maxLong Then 397 | If CDbl(size) * 2 - 1 > maxLong Then 398 | iterations = 2 399 | Else 400 | size = CDbl(size) * 2 - 1 401 | End If 402 | Else 403 | size = size * 2 404 | End If 405 | iterations = iterations / 1.6 406 | DoEvents 407 | Loop Until iterations = 1 408 | End Sub 409 | 410 | -------------------------------------------------------------------------------- /src/LibMemory.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "LibMemory" 2 | '''============================================================================= 3 | ''' VBA MemoryTools 4 | ''' ----------------------------------------------- 5 | ''' https://github.com/cristianbuse/VBA-MemoryTools 6 | ''' ----------------------------------------------- 7 | ''' MIT License 8 | ''' 9 | ''' Copyright (c) 2020 Ion Cristian Buse 10 | ''' 11 | ''' Permission is hereby granted, free of charge, to any person obtaining a copy 12 | ''' of this software and associated documentation files (the "Software"), to 13 | ''' deal in the Software without restriction, including without limitation the 14 | ''' rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 15 | ''' sell copies of the Software, and to permit persons to whom the Software is 16 | ''' furnished to do so, subject to the following conditions: 17 | ''' 18 | ''' The above copyright notice and this permission notice shall be included in 19 | ''' all copies or substantial portions of the Software. 20 | ''' 21 | ''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | ''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | ''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | ''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | ''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | ''' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 27 | ''' IN THE SOFTWARE. 28 | '''============================================================================= 29 | 30 | Option Explicit 31 | Option Private Module 32 | 33 | '******************************************************************************* 34 | '' Methods in this library module allow direct native memory manipulation in VBA 35 | '' regardless of: 36 | '' - the host Application (Excel, Word, AutoCAD etc.) 37 | '' - the operating system (Mac, Windows) 38 | '' - application environment (x32, x64) 39 | '******************************************************************************* 40 | 41 | #If Mac Then 42 | #If VBA7 Then 43 | Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr 44 | Private Declare PtrSafe Function FillMemory Lib "/usr/lib/libc.dylib" Alias "memset" (Destination As Any, ByVal Fill As Byte, ByVal Length As LongPtr) As LongPtr 45 | Public Declare PtrSafe Function MemCopy Lib "/usr/lib/libc.dylib" Alias "memmove" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr) As LongPtr 46 | #Else 47 | Private Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long 48 | Private Declare Function FillMemory Lib "/usr/lib/libc.dylib" Alias "memset" (Destination As Any, ByVal Fill As Byte, ByVal Length As Long) As Long 49 | Public Declare Function MemCopy Lib "/usr/lib/libc.dylib" Alias "memmove" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long) As Long 50 | #End If 51 | #Else 'Windows 52 | 'https://msdn.microsoft.com/en-us/library/mt723419(v=vs.85).aspx 53 | #If VBA7 Then 54 | Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr) 55 | Private Declare PtrSafe Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As LongPtr, ByVal Fill As Byte) 56 | #If TWINBASIC Then 57 | Public Declare PtrSafe Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr) 58 | #End If 59 | #Else 60 | Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) 61 | Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte) 62 | Public Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long) 63 | Public Declare Sub MemFill Lib "kernel32" Alias "RtlFillMemory" (ByVal Destination As Long, ByVal Length As Long, ByVal Fill As Byte) 64 | #End If 65 | #End If 66 | 67 | #If VBA7 = 0 Then 'LongPtr trick discovered by @Greedo (https://github.com/Greedquest) 68 | Public Enum LongPtr 69 | [_] 70 | End Enum 71 | #End If 'https://github.com/cristianbuse/VBA-MemoryTools/issues/3 72 | 73 | #If Win64 Then 74 | Public Const PTR_SIZE As Long = 8 75 | Public Const VARIANT_SIZE As Long = 24 76 | Public Const NULL_PTR As LongLong = 0^ 77 | #Else 78 | Public Const PTR_SIZE As Long = 4 79 | Public Const VARIANT_SIZE As Long = 16 80 | Public Const NULL_PTR As Long = 0& 81 | #End If 82 | 83 | Private Const BYTE_SIZE As Long = 1 84 | Private Const INT_SIZE As Long = 2 85 | Private Const LONG_SIZE As Long = 4 86 | 87 | #If Win64 Then 88 | #If Mac Then 89 | Public Const vbLongLong As Long = 20 'Apparently missing for x64 on Mac 90 | #End If 91 | Public Const vbLongPtr As Long = vbLongLong 92 | #Else 93 | Public Const vbLongLong As Long = 20 'Useful in Select Case logic 94 | Public Const vbLongPtr As Long = vbLong 95 | #End If 96 | 97 | 'https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-oaut/3fe7db9f-5803-4dc4-9d14-5425d3f5461f 98 | 'https://docs.microsoft.com/en-us/windows/win32/api/oaidl/ns-oaidl-variant?redirectedfrom=MSDN 99 | 'Flag used to simulate ByRef Variants 100 | Public Const VT_BYREF As Long = &H4000 101 | 102 | Public Type SAFEARRAYBOUND 103 | cElements As Long 104 | lLbound As Long 105 | End Type 106 | Public Type SAFEARRAY_1D 107 | cDims As Integer 108 | fFeatures As Integer 109 | cbElements As Long 110 | cLocks As Long 111 | pvData As LongPtr 112 | rgsabound0 As SAFEARRAYBOUND 113 | End Type 114 | Public Enum SAFEARRAY_FEATURES 115 | FADF_AUTO = &H1 116 | FADF_STATIC = &H2 117 | FADF_EMBEDDED = &H4 118 | FADF_FIXEDSIZE = &H10 119 | FADF_RECORD = &H20 120 | FADF_HAVEIID = &H40 121 | FADF_HAVEVARTYPE = &H80 122 | FADF_BSTR = &H100 123 | FADF_UNKNOWN = &H200 124 | FADF_DISPATCH = &H400 125 | FADF_VARIANT = &H800 126 | FADF_RESERVED = &HF008 127 | End Enum 128 | Public Enum SAFEARRAY_OFFSETS 129 | cDimsOffset = 0 130 | fFeaturesOffset = cDimsOffset + INT_SIZE 131 | cbElementsOffset = fFeaturesOffset + INT_SIZE 132 | cLocksOffset = cbElementsOffset + LONG_SIZE 133 | pvDataOffset = cLocksOffset + PTR_SIZE 134 | rgsaboundOffset = pvDataOffset + PTR_SIZE 135 | rgsabound0_cElementsOffset = rgsaboundOffset 136 | rgsabound0_lLboundOffset = rgsabound0_cElementsOffset + LONG_SIZE 137 | End Enum 138 | Public Const SAFEARRAY_SIZE As Long = rgsabound0_lLboundOffset + LONG_SIZE 139 | 140 | '******************************************************************************* 141 | 'A new way to copy memory via UDTs - faster than using ByRef Variant 142 | 'Last commit that used ByRef Variant: 143 | 'https://github.com/cristianbuse/VBA-MemoryTools/tree/5058e3333c 144 | '******************************************************************************* 145 | Private Type Byte8: l As Long: r As Long: End Type 146 | Private Type Byte16: l As Byte8: r As Byte8: End Type 147 | Private Type Byte32: l As Byte16: r As Byte16: End Type 148 | Private Type Byte64: l As Byte32: r As Byte32: End Type 149 | Private Type Byte128: l As Byte64: r As Byte64: End Type 150 | Private Type Byte256: l As Byte128: r As Byte128: End Type 151 | Private Type Byte512: l As Byte256: r As Byte256: End Type 152 | Private Type Byte1K: l As Byte512: r As Byte512: End Type 153 | Private Type Byte2K: l As Byte1K: r As Byte1K: End Type 154 | Private Type Byte4K: l As Byte2K: r As Byte2K: End Type 155 | Private Type Byte8K: l As Byte4K: r As Byte4K: End Type 156 | Private Type Byte16K: l As Byte8K: r As Byte8K: End Type 157 | Private Type Byte32K: l As Byte16K: r As Byte16K: End Type 158 | Private Type ArrayAccessor 159 | 'For working directly with data types 160 | dPtr() As LongPtr: dByte() As Byte: dBool() As Boolean 161 | dInt() As Integer: dLong() As Long: dSng() As Single 162 | dCur() As Currency: dDate() As Date: dDbl() As Double 163 | dVar() As Variant: dObj() As Object: dStr() As String 164 | #If Win64 Then 165 | dLongLong() As LongLong 166 | #End If 167 | 'For copying memory without overlap (faster than String) 168 | b16() As Byte16: b32() As Byte32: b64() As Byte64 169 | b128() As Byte128: b256() As Byte256: b512() As Byte512 170 | b1K() As Byte1K: b2K() As Byte2K: b4K() As Byte4K 171 | b8K() As Byte8K: b16K() As Byte16K: b32K() As Byte32K 172 | 'For copying memory with overlap (slower than Byte) 173 | s16() As String * 8: s32() As String * 16: s64() As String * 32 174 | s128() As String * 64: s256() As String * 128: s512() As String * 256 175 | s1K() As String * 512: s2K() As String * 1024: s4K() As String * 2048 176 | s8K() As String * 4096: s16K() As String * 8192: s32K() As String * 16384 177 | 'For referencing fake SAFE ARRAYs 178 | sa() As SAFEARRAY_1D 179 | End Type 180 | Private Type ByteInfo 181 | bit(0 To 7) As Boolean 182 | End Type 183 | Public Type MEMORY_ACCESSOR 184 | isSet As Boolean 185 | ac As ArrayAccessor 186 | sa As SAFEARRAY_1D 187 | End Type 188 | 189 | 'Storage for memory allocated via 'MemAlloc'. Can be deallocated via 'MemFree' 190 | Private m_allocMemory As New Collection 191 | 192 | '******************************************************************************* 193 | 'Returns an initialized (linked) MEMORY_ACCESSOR struct 194 | 'Links all arrays under 'ac' accessor to the 'sa' SAFEARRAY 195 | '******************************************************************************* 196 | Public Sub InitMemoryAccessor(ByRef maToInit As MEMORY_ACCESSOR) 197 | If maToInit.isSet Then Exit Sub 198 | ' 199 | Static ma As MEMORY_ACCESSOR 200 | Dim saPtr As LongPtr: saPtr = VarPtr(maToInit.sa) 201 | Dim i As Long 202 | ' 203 | If Not ma.isSet Then 204 | With ma.sa 205 | .cDims = 1 206 | .cbElements = PTR_SIZE 207 | .cLocks = 1 208 | .fFeatures = FADF_AUTO Or FADF_FIXEDSIZE 209 | End With 210 | CopyMemory ByVal VarPtr(ma.ac), VarPtr(ma.sa), PTR_SIZE 211 | ma.isSet = True 212 | End If 213 | ' 214 | With maToInit.sa 215 | .cDims = 1 216 | .cLocks = 1 217 | .fFeatures = FADF_AUTO Or FADF_FIXEDSIZE 218 | End With 219 | ' 220 | ma.sa.pvData = VarPtr(maToInit.ac) 221 | ma.sa.rgsabound0.cElements = LenB(maToInit.ac) / PTR_SIZE 222 | ' 223 | For i = 0 To ma.sa.rgsabound0.cElements - 1 224 | ma.ac.dPtr(i) = saPtr 225 | Next i 226 | ' 227 | ma.sa.rgsabound0.cElements = 0 228 | ma.sa.pvData = NULL_PTR 229 | ' 230 | maToInit.isSet = True 231 | End Sub 232 | 233 | '******************************************************************************* 234 | 'Read/Write a Byte from/to memory 235 | '******************************************************************************* 236 | Public Property Get MemByte(ByVal memAddress As LongPtr) As Byte 237 | #If Mac Or (VBA7 = 0) Then 238 | CopyMemory MemByte, ByVal memAddress, 1 239 | #ElseIf TWINBASIC Then 240 | GetMem1 memAddress, MemByte 241 | #Else 242 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 243 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 244 | MemByte = ma.ac.dByte(0) 245 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 246 | #End If 247 | End Property 248 | Public Property Let MemByte(ByVal memAddress As LongPtr, ByVal newValue As Byte) 249 | #If Mac Or (VBA7 = 0) Then 250 | CopyMemory ByVal memAddress, newValue, 1 251 | #ElseIf TWINBASIC Then 252 | PutMem1 memAddress, newValue 253 | #Else 254 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 255 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 256 | ma.ac.dByte(0) = newValue 257 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 258 | #End If 259 | End Property 260 | 261 | '******************************************************************************* 262 | 'Read/Write 2 Bytes (Integer) from/to memory 263 | '******************************************************************************* 264 | Public Property Get MemInt(ByVal memAddress As LongPtr) As Integer 265 | #If Mac Or (VBA7 = 0) Then 266 | CopyMemory MemInt, ByVal memAddress, 2 267 | #ElseIf TWINBASIC Then 268 | GetMem2 memAddress, MemInt 269 | #Else 270 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 271 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 272 | MemInt = ma.ac.dInt(0) 273 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 274 | #End If 275 | End Property 276 | Public Property Let MemInt(ByVal memAddress As LongPtr, ByVal newValue As Integer) 277 | #If Mac Or (VBA7 = 0) Then 278 | CopyMemory ByVal memAddress, newValue, 2 279 | #ElseIf TWINBASIC Then 280 | PutMem2 memAddress, newValue 281 | #Else 282 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 283 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 284 | ma.ac.dInt(0) = newValue 285 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 286 | #End If 287 | End Property 288 | 289 | '******************************************************************************* 290 | 'Read/Write 2 Bytes (Boolean) from/to memory 291 | '******************************************************************************* 292 | Public Property Get MemBool(ByVal memAddress As LongPtr) As Boolean 293 | #If Mac Or TWINBASIC Or (VBA7 = 0) Then 294 | CopyMemory MemBool, ByVal memAddress, 2 295 | #Else 296 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 297 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 298 | MemBool = ma.ac.dBool(0) 299 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 300 | #End If 301 | End Property 302 | Public Property Let MemBool(ByVal memAddress As LongPtr, ByVal newValue As Boolean) 303 | #If Mac Or TWINBASIC Or (VBA7 = 0) Then 304 | CopyMemory ByVal memAddress, newValue, 2 305 | #Else 306 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 307 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 308 | ma.ac.dBool(0) = newValue 309 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 310 | #End If 311 | End Property 312 | 313 | '******************************************************************************* 314 | 'Read/Write 4 Bytes (Long) from/to memory 315 | '******************************************************************************* 316 | Public Property Get MemLong(ByVal memAddress As LongPtr) As Long 317 | #If Mac Or (VBA7 = 0) Then 318 | CopyMemory MemLong, ByVal memAddress, 4 319 | #ElseIf TWINBASIC Then 320 | GetMem4 memAddress, MemLong 321 | #Else 322 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 323 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 324 | MemLong = ma.ac.dLong(0) 325 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 326 | #End If 327 | End Property 328 | Public Property Let MemLong(ByVal memAddress As LongPtr, ByVal newValue As Long) 329 | #If Mac Or (VBA7 = 0) Then 330 | CopyMemory ByVal memAddress, newValue, 4 331 | #ElseIf TWINBASIC Then 332 | PutMem4 memAddress, newValue 333 | #Else 334 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 335 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 336 | ma.ac.dLong(0) = newValue 337 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 338 | #End If 339 | End Property 340 | 341 | '******************************************************************************* 342 | 'Read/Write 4 Bytes (Single) from/to memory 343 | '******************************************************************************* 344 | Public Property Get MemSng(ByVal memAddress As LongPtr) As Single 345 | #If Mac Or TWINBASIC Or (VBA7 = 0) Then 346 | CopyMemory MemSng, ByVal memAddress, 4 347 | #Else 348 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 349 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 350 | MemSng = ma.ac.dSng(0) 351 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 352 | #End If 353 | End Property 354 | Public Property Let MemSng(ByVal memAddress As LongPtr, ByVal newValue As Single) 355 | #If Mac Or TWINBASIC Or (VBA7 = 0) Then 356 | CopyMemory ByVal memAddress, newValue, 4 357 | #Else 358 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 359 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 360 | ma.ac.dSng(0) = newValue 361 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 362 | #End If 363 | End Property 364 | 365 | '******************************************************************************* 366 | 'Read/Write 8 Bytes (LongLong) from/to memory 367 | '******************************************************************************* 368 | #If Win64 Or TWINBASIC Then 'TB supports LongLong (8 bytes) in both x32 and x64 369 | Public Property Get MemLongLong(ByVal memAddress As LongLong) As LongLong 370 | #If Mac Or TWINBASIC Or (VBA7 = 0) Then 371 | CopyMemory MemLongLong, ByVal memAddress, 8 372 | #Else 373 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 374 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 375 | MemLongLong = ma.ac.dLongLong(0) 376 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 377 | #End If 378 | End Property 379 | Public Property Let MemLongLong(ByVal memAddress As LongLong, ByVal newValue As LongLong) 380 | #If Mac Or TWINBASIC Or (VBA7 = 0) Then 381 | CopyMemory ByVal memAddress, newValue, 8 382 | #Else 383 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 384 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 385 | ma.ac.dLongLong(0) = newValue 386 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 387 | #End If 388 | End Property 389 | #End If 390 | 391 | '******************************************************************************* 392 | 'Read/Write 4 Bytes (Long on x32) or 8 Bytes (LongLong on x64) from/to memory 393 | 'Note that wrapping MemLong and MemLongLong is about 25% slower because of the 394 | ' extra stack frame! Performance was chosen over code repetition! 395 | '******************************************************************************* 396 | Public Property Get MemLongPtr(ByVal memAddress As LongPtr) As LongPtr 397 | #If Mac Or (VBA7 = 0) Then 398 | CopyMemory MemLongPtr, ByVal memAddress, PTR_SIZE 399 | #ElseIf TWINBASIC Then 400 | GetMemPtr memAddress, MemLongPtr 401 | #Else 402 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 403 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 404 | MemLongPtr = ma.ac.dPtr(0) 405 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 406 | #End If 407 | End Property 408 | Public Property Let MemLongPtr(ByVal memAddress As LongPtr, ByVal newValue As LongPtr) 409 | #If Mac Or (VBA7 = 0) Then 410 | CopyMemory ByVal memAddress, newValue, PTR_SIZE 411 | #ElseIf TWINBASIC Then 412 | PutMemPtr memAddress, newValue 413 | #Else 414 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 415 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 416 | ma.ac.dPtr(0) = newValue 417 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 418 | #End If 419 | End Property 420 | 421 | '******************************************************************************* 422 | 'Read/Write 8 Bytes (Currency) from/to memory 423 | '******************************************************************************* 424 | Public Property Get MemCur(ByVal memAddress As LongPtr) As Currency 425 | #If Mac Or (VBA7 = 0) Then 426 | CopyMemory MemCur, ByVal memAddress, 8 427 | #ElseIf TWINBASIC Then 428 | GetMem8 memAddress, MemCur 429 | #Else 430 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 431 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 432 | MemCur = ma.ac.dCur(0) 433 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 434 | #End If 435 | End Property 436 | Public Property Let MemCur(ByVal memAddress As LongPtr, ByVal newValue As Currency) 437 | #If Mac Or (VBA7 = 0) Then 438 | CopyMemory ByVal memAddress, newValue, 8 439 | #ElseIf TWINBASIC Then 440 | PutMem8 memAddress, newValue 441 | #Else 442 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 443 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 444 | ma.ac.dCur(0) = newValue 445 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 446 | #End If 447 | End Property 448 | 449 | '******************************************************************************* 450 | 'Read/Write 8 Bytes (Date) from/to memory 451 | '******************************************************************************* 452 | Public Property Get MemDate(ByVal memAddress As LongPtr) As Date 453 | #If Mac Or TWINBASIC Or (VBA7 = 0) Then 454 | CopyMemory MemDate, ByVal memAddress, 8 455 | #Else 456 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 457 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 458 | MemDate = ma.ac.dDate(0) 459 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 460 | #End If 461 | End Property 462 | Public Property Let MemDate(ByVal memAddress As LongPtr, ByVal newValue As Date) 463 | #If Mac Or TWINBASIC Or (VBA7 = 0) Then 464 | CopyMemory ByVal memAddress, newValue, 8 465 | #Else 466 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 467 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 468 | ma.ac.dDate(0) = newValue 469 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 470 | #End If 471 | End Property 472 | 473 | '******************************************************************************* 474 | 'Read/Write 8 Bytes (Double) from/to memory 475 | '******************************************************************************* 476 | Public Property Get MemDbl(ByVal memAddress As LongPtr) As Double 477 | #If Mac Or TWINBASIC Or (VBA7 = 0) Then 478 | CopyMemory MemDbl, ByVal memAddress, 8 479 | #Else 480 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 481 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 482 | MemDbl = ma.ac.dDbl(0) 483 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 484 | #End If 485 | End Property 486 | Public Property Let MemDbl(ByVal memAddress As LongPtr, ByVal newValue As Double) 487 | #If Mac Or TWINBASIC Or (VBA7 = 0) Then 488 | CopyMemory ByVal memAddress, newValue, 8 489 | #Else 490 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 491 | ma.sa.pvData = memAddress: ma.sa.rgsabound0.cElements = 1 492 | ma.ac.dDbl(0) = newValue 493 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 494 | #End If 495 | End Property 496 | 497 | '******************************************************************************* 498 | 'Dereference an object by it's pointer 499 | '******************************************************************************* 500 | Public Function MemObj(ByVal memAddress As LongPtr) As Object 501 | If memAddress = NULL_PTR Then Exit Function 502 | ' 503 | #If Mac Or TWINBASIC Or (VBA7 = 0) Then 504 | Dim obj As Object 505 | #If TWINBASIC Then 506 | PutMemPtr ByVal VarPtr(obj), memAddress 507 | #Else 508 | CopyMemory obj, memAddress, PTR_SIZE 509 | #End If 510 | Set MemObj = obj 511 | CopyMemory obj, NULL_PTR, PTR_SIZE 512 | #Else 513 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 514 | ma.sa.pvData = VarPtr(memAddress): ma.sa.rgsabound0.cElements = 1 515 | Set MemObj = ma.ac.dObj(0) 516 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 517 | #End If 518 | End Function 519 | 520 | 'Method purpose explanation at: 521 | 'https://gist.github.com/cristianbuse/b9cc79164c1d31fdb30465f503ac36a9 522 | ' 523 | 'Practical note Jan-2021 from Vladimir Vissoultchev (https://github.com/wqweto): 524 | 'This is mostly not needed in client application code even for LARGEADDRESSAWARE 525 | ' 32-bit processes nowadays as a reliable technique to prevent pointer 526 | ' arithmetic overflows is to VirtualAlloc a 64KB sentinel chunk around 2GB 527 | ' boundary at application start up so that the boundary is never (rarely) 528 | ' crossed in normal pointer operations. 529 | 'This same sentinel chunk fixes native PropertyBag as well which has troubles 530 | ' when internal storage crosses 2GB boundary. 531 | Public Function UnsignedAdd(ByVal unsignedPtr As LongPtr _ 532 | , ByVal signedOffset As LongPtr) As LongPtr 533 | #If Win64 Then 534 | Const minNegative As LongLong = &H8000000000000000^ 535 | #Else 536 | Const minNegative As Long = &H80000000 537 | #End If 538 | UnsignedAdd = ((unsignedPtr Xor minNegative) + signedOffset) Xor minNegative 539 | End Function 540 | 541 | '******************************************************************************* 542 | 'Redirects the instance of a class to another instance of the same class within 543 | ' the scope of a private class Function (not Sub) where the call happens 544 | ' 545 | 'Warning! ONLY call this method from a Private Function of a class! 546 | ' You must pass the return of the function as the 'funcReturn' argument 547 | ' You must pass the address for the return of the function using VarPtr 548 | ' 549 | 'All function return types are supported with the exception User Defined Types 550 | ' (UDTs) ar Arrays of UDT type 551 | 'Example usage: 552 | ' Private Function Init(...) As Boolean 553 | ' RedirectInstance Init, VarPtr(Init), Me, TheOtherInstance 554 | ' 'Run code on private members of TheOtherInstance 555 | ' End Function 556 | '******************************************************************************* 557 | Public Sub RedirectInstance(ByRef funcReturn As Variant _ 558 | , ByVal funcReturnPtr As LongPtr _ 559 | , ByVal currentInstance As stdole.IUnknown _ 560 | , ByVal targetInstance As stdole.IUnknown) 561 | Const methodName As String = "RedirectInstance" 562 | If currentInstance Is Nothing Or targetInstance Is Nothing Then 563 | Err.Raise 91, methodName, "Object not set" 564 | End If 565 | ' 566 | Static ma As MEMORY_ACCESSOR 567 | Dim originalPtr As LongPtr 568 | Dim newPtr As LongPtr 569 | Dim ptr As LongPtr 570 | Dim swapAddress As LongPtr 571 | Dim temp As Object 572 | ' 573 | Set temp = currentInstance: originalPtr = ObjPtr(temp) 574 | Set temp = targetInstance: newPtr = ObjPtr(temp) 575 | ' 576 | If Not ma.isSet Then 577 | InitMemoryAccessor ma 578 | ma.sa.cbElements = PTR_SIZE 579 | End If 580 | ma.sa.pvData = originalPtr 581 | ma.sa.rgsabound0.cElements = 1 582 | ptr = ma.ac.dPtr(0) 583 | ma.sa.pvData = newPtr 584 | If ptr <> ma.ac.dPtr(0) Then 'Faster to compare vTable than TypeName 585 | ma.sa.rgsabound0.cElements = 0 586 | ma.sa.pvData = NULL_PTR 587 | Err.Raise 5, methodName, "Expected same VB class" 588 | End If 589 | ' 590 | 'On x64 the shadow stack space is allocated next to the Function Return 591 | 'On x32 the stack space has a fixed offset (found through testing) 592 | #If Win64 Then 593 | Const memOffsetNonVariant As LongLong = PTR_SIZE 594 | Const memOffsetVariant As LongLong = PTR_SIZE * 3 595 | #Else 596 | Const memOffsetNonVariant As Long = PTR_SIZE * 28 597 | Const memOffsetVariant As Long = PTR_SIZE * 31 598 | #End If 599 | ' 600 | ma.sa.pvData = VarPtr(funcReturn) 601 | If (ma.ac.dInt(0) And VT_BYREF) = 0 Then 602 | ma.sa.pvData = ma.sa.pvData + memOffsetVariant 603 | #If Win64 = 0 Then 604 | ma.sa.pvData = ma.ac.dPtr(0) + PTR_SIZE * 2 605 | #End If 606 | If ma.ac.dPtr(0) = originalPtr Then swapAddress = ma.sa.pvData 607 | Else 608 | Const variantPtrOffset As Long = 8 609 | Dim vt As Integer: vt = ma.ac.dInt(0) Xor VT_BYREF 610 | ' 611 | If (vt = vbObject) Or (vt = vbDataObject) Then 612 | ptr = funcReturnPtr 613 | Else 614 | ma.sa.pvData = ma.sa.pvData + variantPtrOffset 615 | ptr = ma.ac.dPtr(0) 616 | #If Mac Or (Win64 = 0) Then 'Align for Bool/Byte/Int return type 617 | ptr = ptr - (ptr Mod PTR_SIZE) 618 | #End If 619 | End If 620 | ' 621 | ma.sa.pvData = ptr + memOffsetNonVariant 622 | #If Win64 = 0 Then 623 | If vt = vbCurrency Or vt = vbDate Or vt = vbDouble Then 624 | ma.sa.pvData = ma.sa.pvData + PTR_SIZE 625 | End If 626 | ma.sa.pvData = ma.ac.dPtr(0) + PTR_SIZE * 2 627 | #End If 628 | If ma.ac.dPtr(0) = originalPtr Then swapAddress = ma.sa.pvData 629 | End If 630 | ' 631 | If swapAddress = NULL_PTR Then 632 | ma.sa.rgsabound0.cElements = 0 633 | ma.sa.pvData = NULL_PTR 634 | Err.Raise 5, methodName, "Not called from class Func or UDT Func Return" 635 | End If 636 | ' 637 | ma.sa.pvData = swapAddress 638 | ma.ac.dPtr(0) = newPtr 'Redirect Instance 639 | ma.sa.rgsabound0.cElements = 0 640 | ma.sa.pvData = NULL_PTR 641 | End Sub 642 | 643 | '******************************************************************************* 644 | 'Returns the default interface for an object 645 | 'Casting from IUnknown to IDispatch (Object) forces a call to QueryInterface for 646 | ' the IDispatch interface (which knows about the default interface) 647 | '******************************************************************************* 648 | Public Function GetDefaultInterface(ByVal obj As stdole.IUnknown) As Object 649 | Set GetDefaultInterface = obj 650 | End Function 651 | 652 | '******************************************************************************* 653 | 'Returns the memory address of a variable of array type 654 | 'Returns error 5 for a non-array 655 | '******************************************************************************* 656 | Public Function VarPtrArr(ByRef arr As Variant) As LongPtr 657 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 658 | ma.sa.pvData = VarPtr(arr): ma.sa.rgsabound0.cElements = 1 659 | ' 660 | Dim vt As VbVarType: vt = ma.ac.dInt(0) 'VarType(arr) ignores VT_BYREF 661 | If vt And vbArray Then 662 | Const pArrayOffset As Long = 8 663 | VarPtrArr = ma.sa.pvData + pArrayOffset 664 | If vt And VT_BYREF Then 665 | ma.sa.pvData = VarPtrArr 666 | VarPtrArr = ma.ac.dPtr(0) 667 | End If 668 | Else 669 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 670 | Err.Raise 5, "VarPtrArr", "Array required" 671 | End If 672 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 673 | End Function 674 | 675 | '******************************************************************************* 676 | 'Returns the pointer to the underlying SAFEARRAY structure of a VB array 677 | 'Returns error 5 for a non-array 678 | '******************************************************************************* 679 | Public Function ArrPtr(ByRef arr As Variant) As LongPtr 680 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 681 | ma.sa.pvData = VarPtr(arr): ma.sa.rgsabound0.cElements = 1 682 | ' 683 | Dim vt As VbVarType: vt = ma.ac.dInt(0) 'VarType(arr) ignores VT_BYREF 684 | If vt And vbArray Then 685 | Const pArrayOffset As Long = 8 686 | ma.sa.pvData = ma.sa.pvData + pArrayOffset 687 | ArrPtr = ma.ac.dPtr(0) 688 | If vt And VT_BYREF Then 689 | ma.sa.pvData = ArrPtr 690 | ArrPtr = ma.ac.dPtr(0) 691 | End If 692 | Else 693 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 694 | Err.Raise 5, "ArrPtr", "Array required" 695 | End If 696 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 697 | End Function 698 | 699 | '******************************************************************************* 700 | 'Alternative for CopyMemory - not affected by API speed issues on Windows VBA7 701 | '-------------------------- 702 | 'Mac - wrapper around CopyMemory/memmove 703 | 'Win - bytesCount 1 to 33,554,432 - no API calls. Uses MEMORY_ACCESSOR structs 704 | ' - bytesCount < 0 or > 33,554,432 - wrapper around CopyMemory/RtlMoveMemory 705 | '******************************************************************************* 706 | #If (Mac = 0) And (TWINBASIC = 0) And VBA7 Then 707 | Public Sub MemCopy(ByVal destinationPtr As LongPtr _ 708 | , ByVal sourcePtr As LongPtr _ 709 | , ByVal bytesCount As LongPtr) 710 | Const maxSizeSpeedGain As Long = &H2000000 'Beyond this use API directly 711 | If bytesCount < 0 Or bytesCount > maxSizeSpeedGain Then 712 | CopyMemory ByVal destinationPtr, ByVal sourcePtr, bytesCount 713 | Exit Sub 714 | ElseIf destinationPtr = sourcePtr Then 715 | Exit Sub 716 | End If 717 | ' 718 | Static src As MEMORY_ACCESSOR 719 | Static trg As MEMORY_ACCESSOR 720 | Static byteMap(0 To 255) As ByteInfo 721 | Dim i As Long 722 | Dim j As Long 723 | ' 724 | If Not src.isSet Then 725 | InitMemoryAccessor src 726 | InitMemoryAccessor trg 727 | For i = &H1 To &HFF& 728 | With byteMap(i) 729 | For j = 0 To 7 730 | .bit(j) = i And 2 ^ j 731 | Next j 732 | End With 733 | Next i 734 | End If 735 | ' 736 | src.sa.pvData = sourcePtr 737 | trg.sa.pvData = destinationPtr 738 | ' 739 | If bytesCount <= 8 Then 'Optional optimization - small gain 740 | src.sa.rgsabound0.cElements = 1 741 | trg.sa.rgsabound0.cElements = 1 742 | Select Case bytesCount 743 | Case 0: GoTo Clean 744 | Case 1: trg.ac.dByte(0) = src.ac.dByte(0): GoTo Clean 745 | Case 2: trg.ac.dInt(0) = src.ac.dInt(0): GoTo Clean 746 | Case 4: trg.ac.dLong(0) = src.ac.dLong(0): GoTo Clean 747 | Case 8: trg.ac.dCur(0) = src.ac.dCur(0): GoTo Clean 748 | End Select 749 | End If 750 | ' 751 | Dim b As Long: b = CLng(bytesCount) 752 | Dim chunk As Long 753 | Dim overlapR As Boolean 754 | ' 755 | overlapR = (destinationPtr > sourcePtr) And (sourcePtr + b > destinationPtr) 756 | ' 757 | If b And &H7FFF8000 Then 758 | src.sa.cbElements = &H8000& 759 | trg.sa.cbElements = &H8000& 760 | src.sa.rgsabound0.cElements = b \ src.sa.cbElements 761 | trg.sa.rgsabound0.cElements = src.sa.rgsabound0.cElements 762 | ' 763 | chunk = src.sa.rgsabound0.cElements * src.sa.cbElements 764 | b = b - chunk 765 | ' 766 | If overlapR Then 767 | src.sa.pvData = src.sa.pvData + b 768 | trg.sa.pvData = trg.sa.pvData + b 769 | For i = src.sa.rgsabound0.cElements - 1 To 0 Step -1 770 | trg.ac.s32K(i) = src.ac.s32K(i) 771 | Next i 772 | Else 773 | For i = 0 To src.sa.rgsabound0.cElements - 1 774 | trg.ac.b32K(i) = src.ac.b32K(i) 775 | Next i 776 | src.sa.pvData = src.sa.pvData + chunk 777 | trg.sa.pvData = trg.sa.pvData + chunk 778 | End If 779 | chunk = &H8000& 780 | ElseIf overlapR Then 781 | src.sa.pvData = src.sa.pvData + b 782 | trg.sa.pvData = trg.sa.pvData + b 783 | End If 784 | src.sa.rgsabound0.cElements = 1 785 | trg.sa.rgsabound0.cElements = 1 786 | ' 787 | i = b And &HFF& 788 | If i Then 789 | With byteMap(i) 790 | If overlapR Then 791 | If .bit(0) Then src.sa.pvData = src.sa.pvData - 1: trg.sa.pvData = trg.sa.pvData - 1: trg.ac.dByte(0) = src.ac.dByte(0) 792 | If .bit(1) Then src.sa.pvData = src.sa.pvData - 2: trg.sa.pvData = trg.sa.pvData - 2: trg.ac.dInt(0) = src.ac.dInt(0) 793 | If .bit(2) Then src.sa.pvData = src.sa.pvData - 4: trg.sa.pvData = trg.sa.pvData - 4: trg.ac.dLong(0) = src.ac.dLong(0) 794 | If .bit(3) Then src.sa.pvData = src.sa.pvData - 8: trg.sa.pvData = trg.sa.pvData - 8: trg.ac.dCur(0) = src.ac.dCur(0) 795 | If .bit(4) Then src.sa.pvData = src.sa.pvData - 16: trg.sa.pvData = trg.sa.pvData - 16: trg.ac.s16(0) = src.ac.s16(0) 796 | If .bit(5) Then src.sa.pvData = src.sa.pvData - 32: trg.sa.pvData = trg.sa.pvData - 32: trg.ac.s32(0) = src.ac.s32(0) 797 | If .bit(6) Then src.sa.pvData = src.sa.pvData - 64: trg.sa.pvData = trg.sa.pvData - 64: trg.ac.s64(0) = src.ac.s64(0) 798 | If .bit(7) Then src.sa.pvData = src.sa.pvData - 128: trg.sa.pvData = trg.sa.pvData - 128: trg.ac.s128(0) = src.ac.s128(0) 799 | Else 800 | If .bit(0) Then trg.ac.dByte(0) = src.ac.dByte(0): src.sa.pvData = src.sa.pvData + 1: trg.sa.pvData = trg.sa.pvData + 1 801 | If .bit(1) Then trg.ac.dInt(0) = src.ac.dInt(0): src.sa.pvData = src.sa.pvData + 2: trg.sa.pvData = trg.sa.pvData + 2 802 | If .bit(2) Then trg.ac.dLong(0) = src.ac.dLong(0): src.sa.pvData = src.sa.pvData + 4: trg.sa.pvData = trg.sa.pvData + 4 803 | If .bit(3) Then trg.ac.dCur(0) = src.ac.dCur(0): src.sa.pvData = src.sa.pvData + 8: trg.sa.pvData = trg.sa.pvData + 8 804 | If .bit(4) Then trg.ac.b16(0) = src.ac.b16(0): src.sa.pvData = src.sa.pvData + 16: trg.sa.pvData = trg.sa.pvData + 16 805 | If .bit(5) Then trg.ac.b32(0) = src.ac.b32(0): src.sa.pvData = src.sa.pvData + 32: trg.sa.pvData = trg.sa.pvData + 32 806 | If .bit(6) Then trg.ac.b64(0) = src.ac.b64(0): src.sa.pvData = src.sa.pvData + 64: trg.sa.pvData = trg.sa.pvData + 64 807 | If .bit(7) Then trg.ac.b128(0) = src.ac.b128(0): src.sa.pvData = src.sa.pvData + 128: trg.sa.pvData = trg.sa.pvData + 128 808 | End If 809 | End With 810 | End If 811 | ' 812 | i = (b And &H7F00&) / &H100& 813 | If i Then 814 | With byteMap(i) 815 | If overlapR Then 816 | If .bit(0) Then src.sa.pvData = src.sa.pvData - 256: trg.sa.pvData = trg.sa.pvData - 256: trg.ac.s256(0) = src.ac.s256(0) 817 | If .bit(1) Then src.sa.pvData = src.sa.pvData - 512: trg.sa.pvData = trg.sa.pvData - 512: trg.ac.s512(0) = src.ac.s512(0) 818 | If .bit(2) Then src.sa.pvData = src.sa.pvData - 1024: trg.sa.pvData = trg.sa.pvData - 1024: trg.ac.s1K(0) = src.ac.s1K(0) 819 | If .bit(3) Then src.sa.pvData = src.sa.pvData - 2048: trg.sa.pvData = trg.sa.pvData - 2048: trg.ac.s2K(0) = src.ac.s2K(0) 820 | If .bit(4) Then src.sa.pvData = src.sa.pvData - 4096: trg.sa.pvData = trg.sa.pvData - 4096: trg.ac.s4K(0) = src.ac.s4K(0) 821 | If .bit(5) Then src.sa.pvData = src.sa.pvData - 8192: trg.sa.pvData = trg.sa.pvData - 8192: trg.ac.s8K(0) = src.ac.s8K(0) 822 | If .bit(6) Then src.sa.pvData = src.sa.pvData - 16384: trg.sa.pvData = trg.sa.pvData - 16384: trg.ac.s16K(0) = src.ac.s16K(0) 823 | Else 824 | If .bit(0) Then trg.ac.b256(0) = src.ac.b256(0): src.sa.pvData = src.sa.pvData + 256: trg.sa.pvData = trg.sa.pvData + 256 825 | If .bit(1) Then trg.ac.b512(0) = src.ac.b512(0): src.sa.pvData = src.sa.pvData + 512: trg.sa.pvData = trg.sa.pvData + 512 826 | If .bit(2) Then trg.ac.b1K(0) = src.ac.b1K(0): src.sa.pvData = src.sa.pvData + 1024: trg.sa.pvData = trg.sa.pvData + 1024 827 | If .bit(3) Then trg.ac.b2K(0) = src.ac.b2K(0): src.sa.pvData = src.sa.pvData + 2048: trg.sa.pvData = trg.sa.pvData + 2048 828 | If .bit(4) Then trg.ac.b4K(0) = src.ac.b4K(0): src.sa.pvData = src.sa.pvData + 4096: trg.sa.pvData = trg.sa.pvData + 4096 829 | If .bit(5) Then trg.ac.b8K(0) = src.ac.b8K(0): src.sa.pvData = src.sa.pvData + 8192: trg.sa.pvData = trg.sa.pvData + 8192 830 | If .bit(6) Then trg.ac.b16K(0) = src.ac.b16K(0): src.sa.pvData = src.sa.pvData + 16384: trg.sa.pvData = trg.sa.pvData + 16384 831 | End If 832 | End With 833 | End If 834 | Clean: 835 | src.sa.rgsabound0.cElements = 0 836 | trg.sa.rgsabound0.cElements = 0 837 | src.sa.pvData = NULL_PTR 838 | trg.sa.pvData = NULL_PTR 839 | End Sub 840 | #End If 841 | 842 | '******************************************************************************* 843 | 'Copy a param array to another array of Variants while preserving ByRef elements 844 | 'If the paramarray name is 'args' then the call needs to look like this: 845 | ' CloneParamArray Not Not args, outArray 846 | '******************************************************************************* 847 | Public Sub CloneParamArray(ByVal paramPtr As LongPtr, ByRef out() As Variant) 848 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 849 | Dim v As Variant 850 | Dim sa As SAFEARRAY_1D 851 | ' 852 | MemCopy VarPtr(sa), paramPtr, LenB(sa) 853 | v = VarPtr(sa) 854 | sa.cLocks = 1 855 | ' 856 | ma.sa.pvData = VarPtr(v): ma.sa.rgsabound0.cElements = 1 857 | ma.ac.dInt(0) = vbArray + vbVariant 858 | out = v 859 | ma.ac.dInt(0) = vbLongPtr 860 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 861 | End Sub 862 | 863 | '******************************************************************************* 864 | 'Returns the input array wrapped in a ByRef Variant without copying the array 865 | '******************************************************************************* 866 | Public Function GetArrayByRef(ByRef arr As Variant) As Variant 867 | If IsArray(arr) Then 868 | GetArrayByRef = VarPtrArr(arr) 869 | MemInt(VarPtr(GetArrayByRef)) = VarType(arr) Or VT_BYREF 870 | Else 871 | Err.Raise 5, "GetArrayByRef", "Array required" 872 | End If 873 | End Function 874 | 875 | '******************************************************************************* 876 | 'Reads the memory of a String to an Array of Integers 877 | 'Notes: 878 | ' - Ignores the last byte if input has an odd number of bytes 879 | ' - If 'outLength' is -1 (default) then the remaining length is returned 880 | ' - Excess length is ignored 881 | '******************************************************************************* 882 | Public Function StringToIntegers(ByRef s As String _ 883 | , Optional ByVal startIndex As Long = 1 _ 884 | , Optional ByVal outLength As Long = -1 _ 885 | , Optional ByVal outLowBound As Long = 0) As Integer() 886 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 887 | Const methodName As String = "StringToIntegers" 888 | Dim cLen As Long: cLen = Len(s) 889 | 890 | If startIndex < 1 Then 891 | Err.Raise 9, methodName, "Invalid Start Index" 892 | ElseIf outLength < -1 Then 893 | Err.Raise 5, methodName, "Invalid Length for output" 894 | ElseIf outLength = -1 Or startIndex + outLength - 1 > cLen Then 895 | outLength = cLen - startIndex + 1 'Excess length is ignored 896 | If outLength < 0 Then outLength = 0 897 | End If 898 | ' 899 | ma.sa.pvData = StrPtr(s) + (startIndex - 1) * INT_SIZE 900 | ma.sa.cbElements = INT_SIZE 901 | ma.sa.rgsabound0.lLbound = outLowBound 902 | ma.sa.rgsabound0.cElements = outLength 903 | StringToIntegers = ma.ac.dInt 904 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 905 | End Function 906 | 907 | '******************************************************************************* 908 | 'Reads the memory of an Array of Integers into a String 909 | 'Notes: 910 | ' - If 'outLength' is -1 (default) then the remaining length is returned 911 | ' - Excess length is ignored 912 | '******************************************************************************* 913 | Public Function IntegersToString(ByRef ints() As Integer _ 914 | , Optional ByVal startIndex As Long = 0 _ 915 | , Optional ByVal outLength As Long = -1) As String 916 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 917 | Const methodName As String = "IntegersToString" 918 | 919 | If GetArrayDimsCount(ints) <> 1 Then 920 | Err.Raise 5, methodName, "Expected 1D Array of Integers" 921 | ElseIf startIndex < LBound(ints) Then 922 | Err.Raise 9, methodName, "Invalid Start Index" 923 | ElseIf outLength < -1 Then 924 | Err.Raise 5, methodName, "Invalid Length for output" 925 | ElseIf outLength = -1 Or startIndex + outLength - 1 > UBound(ints) Then 926 | outLength = UBound(ints) - startIndex + 1 927 | If outLength < 0 Then Exit Function 928 | End If 929 | ' 930 | ma.sa.pvData = VarPtr(ints(startIndex)) 931 | ma.sa.cbElements = BYTE_SIZE 932 | ma.sa.rgsabound0.cElements = outLength * INT_SIZE 933 | IntegersToString = ma.ac.dByte 934 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 935 | End Function 936 | 937 | '******************************************************************************* 938 | 'Returns an empty array of the requested size and type 939 | '******************************************************************************* 940 | Public Function EmptyArray(ByVal numberOfDimensions As Long _ 941 | , ByVal vType As VbVarType) As Variant 942 | Const methodName As String = "EmptyArray" 943 | Const MAX_DIMENSION As Long = 60 944 | ' 945 | If numberOfDimensions < 1 Or numberOfDimensions > MAX_DIMENSION Then 946 | Err.Raise 5, methodName, "Invalid number of dimensions" 947 | End If 948 | Select Case vType 949 | Case vbByte, vbInteger, vbLong, vbLongLong 'Integers 950 | Case vbCurrency, vbDecimal, vbDouble, vbSingle, vbDate 'Decimal-point 951 | Case vbBoolean, vbString, vbObject, vbDataObject, vbVariant 'Other 952 | Case Else 953 | Err.Raise 13, methodName, "Type mismatch" 954 | End Select 955 | ' 956 | Static fakeSafeArray() As Long 957 | Static ma As MEMORY_ACCESSOR 958 | Static v As Variant 959 | #If Win64 Then 960 | Const safeArraySize = 6 961 | #Else 962 | Const safeArraySize = 4 963 | #End If 964 | Const fFeaturesHi As Long = FADF_HAVEVARTYPE * &H10000 965 | Dim i As Long 966 | ' 967 | If Not ma.isSet Then 968 | InitMemoryAccessor ma 969 | ReDim fakeSafeArray(0 To safeArraySize + MAX_DIMENSION * 2 - 1) 970 | fakeSafeArray(1) = 1 'cbElements member - needs to be non-zero 971 | v = VarPtr(fakeSafeArray(0)) 'The fake ArrPtr 972 | ' 973 | 'Set 'cElements' to 1 for each SAFEARRAYBOUND 974 | For i = safeArraySize To UBound(fakeSafeArray, 1) Step 2 975 | fakeSafeArray(i) = 1 976 | Next i 977 | End If 978 | fakeSafeArray(0) = fFeaturesHi + numberOfDimensions 'cDims and fFeatures 979 | i = safeArraySize + (numberOfDimensions - 1) * 2 'Highest dimension position 980 | ' 981 | fakeSafeArray(i) = 0 'Highest dimension must have 0 'cElements' 982 | ma.sa.pvData = VarPtr(v): ma.sa.rgsabound0.cElements = 1 983 | ma.ac.dInt(0) = vbArray + vType 984 | EmptyArray = v 985 | ma.ac.dInt(0) = vbLongPtr 986 | ma.sa.rgsabound0.cElements = 0: ma.sa.pvData = NULL_PTR 987 | fakeSafeArray(i) = 1 988 | End Function 989 | 990 | '******************************************************************************* 991 | 'Allows user to update the LBound Index for an array dimension 992 | '******************************************************************************* 993 | Public Sub UpdateLBound(ByRef arr As Variant _ 994 | , ByVal dimension As Long _ 995 | , ByVal newLB As Long) 996 | Const bOffset As Long = rgsaboundOffset + 4 997 | Const methodName As String = "UpdateLBound" 998 | Const maxL As Long = &H7FFFFFFF 999 | Dim dimensionCount As Long: dimensionCount = GetArrayDimsCount(arr) 1000 | ' 1001 | If dimension < 1 Or dimension > dimensionCount Then 1002 | Err.Raise 5, methodName, "Invalid dimension or not array" 1003 | ElseIf maxL - UBound(arr, dimension) + LBound(arr, dimension) < newLB Then 1004 | Err.Raise 5, methodName, "New bound overflow" 1005 | End If 1006 | MemLong(ArrPtr(arr) + bOffset + (dimensionCount - dimension) * 8) = newLB 1007 | End Sub 1008 | 1009 | '******************************************************************************* 1010 | 'Returns the Number of dimensions for an input array 1011 | 'Returns 0 if array is uninitialized or input not an array 1012 | 'Note that a zero-length array has 1 dimension! Ex. Array() bounds are (0 to -1) 1013 | '******************************************************************************* 1014 | Private Function GetArrayDimsCount(ByRef arr As Variant) As Long 1015 | Const MAX_DIMENSION As Long = 60 'VB limit 1016 | Dim dimension As Long 1017 | Dim tempBound As Long 1018 | ' 1019 | On Error GoTo FinalDimension 1020 | For dimension = 1 To MAX_DIMENSION 1021 | tempBound = LBound(arr, dimension) 1022 | Next dimension 1023 | FinalDimension: 1024 | GetArrayDimsCount = dimension - 1 1025 | End Function 1026 | 1027 | '******************************************************************************* 1028 | 'Fills target memory with zero 1029 | '******************************************************************************* 1030 | Public Sub MemZero(ByVal destinationPtr As LongPtr, ByVal bytesCount As LongPtr) 1031 | MemFill destinationPtr, bytesCount, 0 1032 | End Sub 1033 | 1034 | '******************************************************************************* 1035 | 'Fills target memory with the specified Byte value 1036 | '******************************************************************************* 1037 | #If Mac Or VBA7 Then 1038 | Public Sub MemFill(ByVal destinationPtr As LongPtr _ 1039 | , ByVal bytesCount As LongPtr _ 1040 | , ByVal fillByte As Byte) 1041 | #If Mac Then 1042 | FillMemory ByVal destinationPtr, fillByte, bytesCount 1043 | #Else 1044 | If bytesCount = 0 Then Exit Sub 1045 | Const maxSizeSpeedGain As Long = &H100000 'Beyond this use API directly 1046 | If bytesCount < 0 Or bytesCount > maxSizeSpeedGain Then 1047 | FillMemory ByVal destinationPtr, bytesCount, fillByte 1048 | Exit Sub 1049 | End If 1050 | ' 1051 | Const maxSizeMidB As Long = &H2000 'Beyond this use MemCopy 1052 | Dim bytesLeft As Long 1053 | Dim bytes As Long 1054 | Dim chunk As Long 1055 | ' 1056 | If bytesCount > maxSizeMidB Then 1057 | bytes = maxSizeMidB 1058 | bytesLeft = CLng(bytesCount) - maxSizeMidB 1059 | chunk = maxSizeMidB 1060 | Else 1061 | bytes = CLng(bytesCount) 1062 | End If 1063 | ' 1064 | Const bstrPrefixSize As Long = 4 1065 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 1066 | Dim i As Long 1067 | ' 1068 | ma.sa.pvData = destinationPtr 1069 | ma.sa.cbElements = BYTE_SIZE 1070 | If bytes > 5 Then 'Use MidB 1071 | Dim s As String 1072 | ' 1073 | ma.sa.rgsabound0.cElements = 5 1074 | ma.ac.dLong(0) = bytes - bstrPrefixSize 1075 | ma.ac.dByte(4) = fillByte 1076 | ma.sa.pvData = VarPtr(s) 1077 | ma.ac.dPtr(0) = destinationPtr + bstrPrefixSize 1078 | MidB$(s, 2) = s 'The actual fill 1079 | ma.ac.dPtr(0) = NULL_PTR 1080 | ma.sa.pvData = destinationPtr 1081 | bytes = 4 1082 | End If 1083 | ma.sa.rgsabound0.cElements = bytes 1084 | For i = 0 To bytes - 1 1085 | ma.ac.dByte(i) = fillByte 1086 | Next i 1087 | ma.sa.rgsabound0.cElements = 0 1088 | ma.sa.pvData = NULL_PTR 1089 | ' 1090 | Do While bytesLeft > 0 1091 | If chunk > bytesLeft Then bytes = bytesLeft Else bytes = chunk 1092 | MemCopy destinationPtr + chunk, destinationPtr, bytes 1093 | bytesLeft = bytesLeft - bytes 1094 | chunk = chunk * 2 1095 | Loop 1096 | #End If 1097 | End Sub 1098 | #End If 1099 | 1100 | '******************************************************************************* 1101 | 'Allocates persistent memory 1102 | 'Allocated memory is deallocated automatically on state loss or via 'MemFree' 1103 | '******************************************************************************* 1104 | Public Function MemAlloc(ByVal byteSize As Long) As LongPtr 1105 | Static ma As MEMORY_ACCESSOR: If Not ma.isSet Then InitMemoryAccessor ma 1106 | Static i As stdole.IEnumVARIANT 1107 | Static nextItemAddr As LongPtr 1108 | Static arr() As Byte 1109 | Static arrAddr As LongPtr 1110 | Dim aPtr As LongPtr 1111 | Dim pvPtr As LongPtr 1112 | ' 1113 | If byteSize < 1 Then Exit Function 1114 | ReDim arr(0 To byteSize - 1) 1115 | ' 1116 | pvPtr = VarPtr(arr(0)) 1117 | ' 1118 | If nextItemAddr = NULL_PTR Then 1119 | Set i = m_allocMemory.[_NewEnum] 1120 | nextItemAddr = ObjPtr(i) + PTR_SIZE * 2 1121 | arrAddr = VarPtrArr(arr) 1122 | End If 1123 | If m_allocMemory.Count = 0 Then 1124 | m_allocMemory.Add Empty, CStr(pvPtr) 1125 | Else 1126 | m_allocMemory.Add Empty, CStr(pvPtr), 1 1127 | End If 1128 | i.Reset 'Update pointer at 'nextItemAddr' to the latest item 1129 | ' 1130 | ma.sa.pvData = arrAddr 1131 | ma.sa.rgsabound0.cElements = 1 1132 | aPtr = ma.ac.dPtr(0) 'Same as ArrPtr(arr) 1133 | ma.ac.dPtr(0) = NULL_PTR 'Clear 'arr' variable 1134 | ma.sa.pvData = nextItemAddr 1135 | ma.sa.pvData = ma.ac.dPtr(0) + 8 1136 | ma.ac.dPtr(0) = aPtr 1137 | ma.sa.pvData = ma.sa.pvData - 8 1138 | ma.ac.dInt(0) = vbArray + vbByte 1139 | ma.sa.rgsabound0.cElements = 0 1140 | ma.sa.pvData = NULL_PTR 1141 | ' 1142 | MemAlloc = pvPtr 1143 | End Function 1144 | 1145 | '******************************************************************************* 1146 | 'Deallocates memory that was allocated with 'MemAlloc' 1147 | '******************************************************************************* 1148 | Public Sub MemFree(ByVal memAddress As LongPtr) 1149 | On Error Resume Next 1150 | m_allocMemory.Remove CStr(memAddress) 1151 | On Error GoTo 0 1152 | End Sub 1153 | -------------------------------------------------------------------------------- /src/Test/TestLibMemory.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestLibMemory" 2 | '''============================================================================= 3 | ''' VBA MemoryTools 4 | ''' ----------------------------------------------- 5 | ''' https://github.com/cristianbuse/VBA-MemoryTools 6 | ''' ----------------------------------------------- 7 | ''' MIT License 8 | ''' 9 | ''' Copyright (c) 2020 Ion Cristian Buse 10 | ''' 11 | ''' Permission is hereby granted, free of charge, to any person obtaining a copy 12 | ''' of this software and associated documentation files (the "Software"), to 13 | ''' deal in the Software without restriction, including without limitation the 14 | ''' rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 15 | ''' sell copies of the Software, and to permit persons to whom the Software is 16 | ''' furnished to do so, subject to the following conditions: 17 | ''' 18 | ''' The above copyright notice and this permission notice shall be included in 19 | ''' all copies or substantial portions of the Software. 20 | ''' 21 | ''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | ''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | ''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | ''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | ''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | ''' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 27 | ''' IN THE SOFTWARE. 28 | '''============================================================================= 29 | 30 | Option Explicit 31 | Option Private Module 32 | 33 | Public Sub RunAllTests() 34 | TestReadByte 35 | TestWriteByte 36 | TestReadInteger 37 | TestWriteInteger 38 | TestReadLong 39 | TestWriteLong 40 | TestReadLongLong 41 | TestWriteLongLong 42 | ' 43 | TestReadBoolean 44 | TestWriteBoolean 45 | TestReadSingle 46 | TestWriteSingle 47 | TestReadCurrency 48 | TestWriteCurrency 49 | TestReadDate 50 | TestWriteDate 51 | TestReadDouble 52 | TestWriteDouble 53 | ' 54 | TestMemCopy 55 | TestCloneParamArray 56 | TestStringToIntegers 57 | TestIntegersToString 58 | TestEmptyArray 59 | TestMemFill 60 | ' 61 | Debug.Print "Finished running tests at " & Now() 62 | End Sub 63 | 64 | Private Sub TestReadByte() 65 | Dim b As Byte 66 | Dim i As Integer 67 | Dim l1 As Long, l2 As Long, l3 As Long, l4 As Long 68 | Dim l As Long 69 | Dim s As String 70 | ' 71 | For l1 = 0 To 255 72 | b = l1 73 | Debug.Assert MemByte(VarPtr(b)) = b 74 | Next l1 75 | ' 76 | For l1 = 0 To 255 77 | For l2 = 0 To 255 78 | i = ((l1 Xor &H8000) + l2 * 256) Xor &H8000 79 | Debug.Assert MemByte(VarPtr(i)) = l1 80 | Debug.Assert MemByte(VarPtr(i) + 1) = l2 81 | Next l2 82 | Next l1 83 | ' 84 | For l1 = 0 To 255 Step 25 85 | For l2 = 0 To 255 Step 25 86 | For l3 = 0 To 255 Step 5 87 | For l4 = 0 To 255 Step 5 88 | l = (((l1 + l2 * 256 + l3 * 256 ^ 2) Xor &H80000000) + l4 * 256 ^ 3) Xor &H80000000 89 | Debug.Assert MemByte(VarPtr(l)) = l1 90 | Debug.Assert MemByte(VarPtr(l) + 1) = l2 91 | Debug.Assert MemByte(VarPtr(l) + 2) = l3 92 | Debug.Assert MemByte(VarPtr(l) + 3) = l4 93 | Next l4 94 | Next l3 95 | Next l2 96 | Next l1 97 | ' 98 | s = Chr$(66) 99 | Debug.Assert MemByte(StrPtr(s)) = 66 100 | Debug.Assert MemByte(StrPtr(s) + 1) = 0 101 | Debug.Assert MemByte(StrPtr(s) - 4) = 2 'Byte Count in BSTR 102 | End Sub 103 | 104 | Private Sub TestWriteByte() 105 | Dim b As Byte 106 | Dim i As Integer 107 | Dim l1 As Long, l2 As Long, l3 As Long, l4 As Long 108 | Dim l As Long 109 | Dim s As String 110 | ' 111 | For l1 = 0 To 255 112 | MemByte(VarPtr(b)) = l1 113 | Debug.Assert b = l1 114 | Next l1 115 | ' 116 | For l1 = 0 To 255 117 | For l2 = 0 To 255 118 | MemByte(VarPtr(i)) = l1 119 | MemByte(VarPtr(i) + 1) = l2 120 | Debug.Assert i = ((l1 Xor &H8000) + l2 * 256) Xor &H8000 121 | Next l2 122 | Next l1 123 | ' 124 | For l1 = 0 To 255 Step 25 125 | For l2 = 0 To 255 Step 25 126 | For l3 = 0 To 255 Step 5 127 | For l4 = 0 To 255 Step 5 128 | MemByte(VarPtr(l)) = l1 129 | MemByte(VarPtr(l) + 1) = l2 130 | MemByte(VarPtr(l) + 2) = l3 131 | MemByte(VarPtr(l) + 3) = l4 132 | Debug.Assert l = (((l1 + l2 * 256 + l3 * 256 ^ 2) Xor &H80000000) + l4 * 256 ^ 3) Xor &H80000000 133 | Next l4 134 | Next l3 135 | Next l2 136 | Next l1 137 | ' 138 | s = Space(1) 139 | MemByte(StrPtr(s)) = 66 140 | Debug.Assert s = "B" 141 | MemByte(StrPtr(s) - 4) = 4 142 | Debug.Assert LenB(s) = 4 143 | MemByte(StrPtr(s) - 4) = 2 144 | Debug.Assert LenB(s) = 2 145 | End Sub 146 | 147 | Private Sub TestReadInteger() 148 | Dim i As Integer 149 | Dim l1 As Long, l2 As Long 150 | Dim l As Long 151 | Dim s As String 152 | ' 153 | For l1 = &H8000 To &H7FFF 154 | i = l1 155 | Debug.Assert MemInt(VarPtr(i)) = i 156 | Next l1 157 | ' 158 | For l1 = &H8000 To &H7FFF Step 128 159 | For l2 = &H8000 To &H7FFF Step 128 160 | l = l1 + IIf(l1 And &H8000, &H10000, 0) + l2 * &H10000 161 | Debug.Assert MemInt(VarPtr(l)) = l1 162 | Debug.Assert MemInt(VarPtr(l) + 2) = l2 163 | Next l2 164 | Next l1 165 | ' 166 | s = Chr$(66) & Chr$(65) 167 | Debug.Assert MemInt(StrPtr(s)) = 66 168 | Debug.Assert MemInt(StrPtr(s) + 2) = 65 169 | Debug.Assert MemInt(StrPtr(s) - 4) = 4 'Byte Count in BSTR 170 | End Sub 171 | 172 | Private Sub TestWriteInteger() 173 | Dim i As Integer 174 | Dim l1 As Long, l2 As Long 175 | Dim l As Long 176 | Dim s As String 177 | ' 178 | For l1 = &H8000 To &H7FFF 179 | MemInt(VarPtr(i)) = l1 180 | Debug.Assert i = l1 181 | Next l1 182 | ' 183 | For l1 = &H8000 To &H7FFF Step 128 184 | For l2 = &H8000 To &H7FFF Step 128 185 | MemInt(VarPtr(l)) = l1 186 | MemInt(VarPtr(l) + 2) = l2 187 | Debug.Assert l = l1 + IIf(l1 And &H8000, &H10000, 0) + l2 * &H10000 188 | Next l2 189 | Next l1 190 | ' 191 | s = Space(2) 192 | MemInt(StrPtr(s)) = 66 193 | Debug.Assert Mid$(s, 1, 1) = "B" 194 | MemInt(StrPtr(s) + 2) = 65 195 | Debug.Assert Mid$(s, 2, 1) = "A" 196 | MemInt(StrPtr(s) - 4) = 2 197 | Debug.Assert LenB(s) = 2 198 | MemInt(StrPtr(s) - 4) = 4 199 | Debug.Assert LenB(s) = 4 200 | End Sub 201 | 202 | Private Sub TestReadLong() 203 | Dim l As Long 204 | Dim s As String 205 | Dim c As Currency 206 | ' 207 | For l = &H80000000 To &H7FFFFFFF - &H1000 Step &H1000 208 | Debug.Assert MemLong(VarPtr(l)) = l 209 | c = l / 10000 210 | Debug.Assert MemLong(VarPtr(c)) = l 211 | Debug.Assert MemLong(VarPtr(c) + 4) = IIf(l And &H80000000, -1, 0) 212 | Next l 213 | l = &H7FFFFFFF 214 | Debug.Assert MemLong(VarPtr(l)) = l 215 | c = l / 10000 216 | Debug.Assert MemLong(VarPtr(c)) = l 217 | ' 218 | s = Chr$(65) & Chr$(66) 219 | Debug.Assert MemLong(StrPtr(s)) = 65 + 66 * 256 ^ 2 220 | Debug.Assert MemLong(StrPtr(s) + 2) = 66 221 | Debug.Assert MemLong(StrPtr(s) - 4) = 4 'Byte Count in BSTR 222 | End Sub 223 | 224 | Private Sub TestWriteLong() 225 | Dim l As Long, l1 As Long 226 | Dim s As String 227 | Dim c As Currency 228 | ' 229 | For l1 = &H80000000 To &H7FFFFFFF - &H1000 Step &H1000 230 | MemLong(VarPtr(l)) = l1 231 | Debug.Assert l = l1 232 | ' 233 | MemLong(VarPtr(c)) = l1 234 | MemLong(VarPtr(c) + 4) = IIf(l And &H80000000, -1, 0) 235 | Debug.Assert c = l1 / 10000 236 | Next l1 237 | l1 = &H7FFFFFFF 238 | MemLong(VarPtr(l)) = l1 239 | Debug.Assert l = l1 240 | MemLong(VarPtr(c)) = l1 241 | Debug.Assert c = l1 / 10000 242 | ' 243 | s = Chr$(65) & Chr$(66) 244 | Debug.Assert MemLong(StrPtr(s)) = 65 + 66 * 256 ^ 2 245 | Debug.Assert MemLong(StrPtr(s) + 2) = 66 246 | Debug.Assert MemLong(StrPtr(s) - 4) = 4 'Byte Count in BSTR 247 | ' 248 | s = Space(2) 249 | MemLong(StrPtr(s)) = 65 + 66 * 256 ^ 2 250 | Debug.Assert Mid$(s, 1, 2) = "AB" 251 | MemLong(StrPtr(s) - 4) = 2 252 | Debug.Assert LenB(s) = 2 253 | MemInt(StrPtr(s) - 4) = 4 254 | Debug.Assert LenB(s) = 4 255 | End Sub 256 | 257 | Private Sub TestReadLongLong() 258 | #If Win64 Then 259 | Dim ll As LongLong 260 | Dim s As String 261 | Const loopStep As LongLong = &H1000000000000^ 262 | ' 263 | ll = &H8000000000000000^ 264 | Do 265 | Debug.Assert MemLongLong(VarPtr(ll)) = ll 266 | ll = ll + loopStep 267 | Loop Until ll > &H7FFFFFFFFFFFFFFF^ - loopStep 268 | ' 269 | s = Chr$(65) & Chr$(66) & Chr$(67) & Chr$(68) 270 | Debug.Assert MemLongLong(StrPtr(s)) = &H44004300420041^ 271 | Debug.Assert MemLongLong(VarPtr(s)) = StrPtr(s) 272 | #End If 273 | End Sub 274 | 275 | Private Sub TestWriteLongLong() 276 | #If Win64 Then 277 | Dim ll As LongLong, ll2 As LongLong, ptr As LongLong 278 | Dim s As String, s2 As String 279 | Const loopStep As LongLong = &H1000000000000^ 280 | ' 281 | ll = &H8000000000000000^ 282 | Do 283 | MemLongLong(VarPtr(ll2)) = ll 284 | Debug.Assert ll = ll2 285 | ll = ll + loopStep 286 | Loop Until ll > &H7FFFFFFFFFFFFFFF^ - loopStep 287 | ' 288 | s = Space(4) 289 | MemLongLong(StrPtr(s)) = &H44004300420041^ 290 | Debug.Assert Mid$(s, 1, 4) = "ABCD" 291 | ' 292 | s2 = "TEST" 293 | ptr = StrPtr(s) 294 | MemLongLong(VarPtr(s)) = StrPtr(s2) 295 | Debug.Assert Mid$(s, 1, 4) = "TEST" 296 | MemLongLong(VarPtr(s)) = ptr 297 | Debug.Assert Mid$(s, 1, 4) = "ABCD" 298 | #End If 299 | End Sub 300 | 301 | Private Sub TestReadBoolean() 302 | Dim b As Boolean 303 | Dim i As Integer 304 | ' 305 | b = False 306 | Debug.Assert MemBool(VarPtr(b)) = b 307 | b = True 308 | Debug.Assert MemBool(VarPtr(b)) = b 309 | ' 310 | i = 0 311 | Debug.Assert MemBool(VarPtr(i)) = False 312 | i = -1 313 | Debug.Assert MemBool(VarPtr(i)) = True 314 | i = 1 315 | Debug.Assert MemBool(VarPtr(i)) = 1 316 | Debug.Assert MemBool(VarPtr(i)) <> True 317 | Debug.Assert MemBool(VarPtr(i)) <> False 318 | ' 319 | i = -255 320 | Debug.Assert MemBool(VarPtr(i)) = -255 321 | Debug.Assert MemBool(VarPtr(i)) <> True 322 | Debug.Assert MemBool(VarPtr(i)) <> False 323 | End Sub 324 | 325 | Private Sub TestWriteBoolean() 326 | Dim b As Boolean 327 | Dim i As Integer 328 | ' 329 | MemBool(VarPtr(b)) = False 330 | Debug.Assert b = False 331 | MemBool(VarPtr(b)) = True 332 | Debug.Assert b = True 333 | MemBool(VarPtr(b)) = 0 'The 'newValue' parameter converts to Bool before memory is written 334 | Debug.Assert b = False 335 | MemBool(VarPtr(b)) = 5 'The 'newValue' parameter converts to Bool before memory is written 336 | Debug.Assert b = True 337 | MemBool(VarPtr(b)) = -5 'The 'newValue' parameter converts to Bool before memory is written 338 | Debug.Assert b = True 339 | ' 340 | MemBool(VarPtr(i)) = False 341 | Debug.Assert i = 0 342 | MemBool(VarPtr(i)) = True 343 | Debug.Assert i = -1 344 | MemBool(VarPtr(i)) = 5 'The 'newValue' parameter converts to Bool before memory is written 345 | Debug.Assert i = -1 346 | End Sub 347 | 348 | Private Sub TestReadSingle() 349 | Dim s As Single 350 | Dim v As Variant 351 | Dim l As Long 352 | ' 353 | Debug.Assert MemSng(VarPtr(&H7F800000)) = PosInf() 354 | Debug.Assert MemSng(VarPtr(&HFF800000)) = NegInf() 355 | Debug.Assert CStr(MemSng(VarPtr(&HFFC00000))) = CStr(SNAN()) 356 | Debug.Assert CStr(MemSng(VarPtr(&H7FC00000))) = CStr(QNAN()) 357 | ' 358 | For Each v In Array(-3.402823E+38, -1.401298E-45, 0, 1.401298E-45, 3.402823E+38) 359 | s = v 360 | Debug.Assert MemSng(VarPtr(s)) = s 361 | Next v 362 | ' 363 | For l = &H80000000 To &H7FFFFFFF - &H10000 Step &H10000 364 | If (l And &H7F800000) <> &H7F800000 Then 'Skip INF/NAN 365 | Debug.Assert MemSng(VarPtr(l)) = LongToSingle(l) 366 | End If 367 | Next l 368 | End Sub 369 | Public Function PosInf() As Double 370 | On Error Resume Next 371 | PosInf = 1 / 0 372 | On Error GoTo 0 373 | End Function 374 | Public Function NegInf() As Double 375 | NegInf = -PosInf 376 | End Function 377 | Public Function SNAN() As Double 378 | On Error Resume Next 379 | SNAN = 0 / 0 380 | On Error GoTo 0 381 | End Function 382 | Public Function QNAN() As Double 383 | QNAN = -SNAN 384 | End Function 385 | Private Function LongToSingle(ByVal l As Long) As Single 386 | Dim signBit As Long 387 | Dim exponentBits As Long 388 | Dim fractionBits As Single 389 | Dim i As Long 390 | ' 391 | signBit = IIf(l And &H80000000, -1, 1) 392 | For i = 23 To 30 393 | exponentBits = exponentBits - CBool(l And 2 ^ i) * 2 ^ (i - 23) 394 | Next i 395 | For i = 1 To 23 396 | fractionBits = fractionBits - CBool(l And 2 ^ (23 - i)) * 2 ^ -i 397 | Next i 398 | If exponentBits = 0 Then 399 | If fractionBits <> 0 Then exponentBits = -126 400 | ElseIf exponentBits = 255 Then 401 | If fractionBits = 0 Then 402 | LongToSingle = PosInf() 403 | Else 404 | LongToSingle = SNAN() 405 | End If 406 | If signBit = -1 Then LongToSingle = -LongToSingle 407 | Exit Function 408 | Else 409 | Const bias As Long = 127 410 | exponentBits = exponentBits - bias 411 | fractionBits = fractionBits + 1 412 | End If 413 | LongToSingle = signBit * 2 ^ exponentBits * fractionBits 414 | End Function 415 | 416 | Private Sub TestWriteSingle() 417 | Dim s As Single, s2 As Single 418 | Dim v As Variant 419 | Dim l As Long 420 | ' 421 | MemSng(VarPtr(l)) = PosInf() 422 | Debug.Assert l = &H7F800000 423 | ' 424 | MemSng(VarPtr(l)) = NegInf() 425 | Debug.Assert l = &HFF800000 426 | ' 427 | MemSng(VarPtr(l)) = SNAN() 428 | Debug.Assert l = &HFFC00000 429 | ' 430 | MemSng(VarPtr(l)) = QNAN() 431 | Debug.Assert l = &H7FC00000 432 | ' 433 | For Each v In Array(-3.402823E+38, -1.401298E-45, 0, 1.401298E-45, 3.402823E+38) 434 | MemSng(VarPtr(s)) = v 435 | Debug.Assert s = v 436 | Next v 437 | ' 438 | For l = &H80000000 To &H7FFFFFFF - &H10000 Step &H10000 439 | If (l And &H7F800000) <> &H7F800000 Then 'Skip INF/NAN 440 | s = LongToSingle(l) 441 | MemSng(VarPtr(s2)) = s 442 | Debug.Assert s = s2 443 | End If 444 | Next l 445 | End Sub 446 | 447 | Private Sub TestReadCurrency() 448 | Dim c As Currency 449 | Dim l As Long 450 | Dim s As String 451 | ' 452 | For l = 1 To 62 453 | c = -2 ^ l / 10000 454 | Debug.Assert MemCur(VarPtr(c)) = c 455 | c = (2 ^ l - 1) / 10000 456 | Debug.Assert MemCur(VarPtr(c)) = c 457 | Next l 458 | c = CCur("-922337203685477.5808") 459 | Debug.Assert MemCur(VarPtr(c)) = c 460 | c = CCur("922337203685477.5807") 461 | Debug.Assert MemCur(VarPtr(c)) = c 462 | ' 463 | s = Chr$(65) & Chr$(66) & Chr$(67) & Chr$(68) 464 | Debug.Assert MemCur(StrPtr(s)) = CCur("1914058618345.8881") 465 | End Sub 466 | 467 | Private Sub TestWriteCurrency() 468 | Dim c As Currency, c2 As Currency 469 | Dim l As Long 470 | Dim s As String 471 | ' 472 | For l = 1 To 62 473 | c = -2 ^ l / 10000 474 | MemCur(VarPtr(c2)) = c 475 | Debug.Assert c = c2 476 | c = (2 ^ l - 1) / 10000 477 | MemCur(VarPtr(c2)) = c 478 | Debug.Assert c = c2 479 | Next l 480 | c = CCur("-922337203685477.5808") 481 | MemCur(VarPtr(c2)) = c 482 | Debug.Assert c = c2 483 | c = CCur("922337203685477.5807") 484 | MemCur(VarPtr(c2)) = c 485 | Debug.Assert c = c2 486 | ' 487 | s = Space(4) 488 | MemCur(StrPtr(s)) = CCur("1914058618345.8881") 489 | Debug.Assert Mid$(s, 1, 4) = "ABCD" 490 | End Sub 491 | 492 | Private Sub TestReadDate() 493 | Const minDate As Date = #1/1/100# 494 | Const maxDate As Date = #12/31/9999# 495 | ' 496 | Dim dt As Date 497 | Dim i As Long, j As Long 498 | Dim d As Double 499 | Dim s As String 500 | ' 501 | For i = minDate To maxDate Step 200 502 | d = CDbl(i) 'No time added 503 | dt = d 504 | Debug.Assert MemDate(VarPtr(d)) = dt 505 | For j = 1 To 100 506 | d = CDbl(i) + Rnd() 'Add some random time (hh:mm:ss) 507 | dt = d 508 | Debug.Assert MemDate(VarPtr(d)) = dt 509 | Next j 510 | Next i 511 | ' 512 | d = CDbl(minDate) - 1000 'Invalid date 513 | dt = MemDate(VarPtr(d)) 514 | Debug.Assert dt + 1000 = minDate 515 | ' 516 | On Error Resume Next 517 | s = CStr(dt) 518 | Debug.Assert Err.Number = 5 519 | On Error GoTo 0 520 | ' 521 | d = CDbl(maxDate) + 5000 'Invalid date 522 | dt = MemDate(VarPtr(d)) 523 | Debug.Assert dt - 5000 = maxDate 524 | ' 525 | On Error Resume Next 526 | s = CStr(dt) 527 | Debug.Assert Err.Number = 5 528 | On Error GoTo 0 529 | End Sub 530 | 531 | Private Sub TestWriteDate() 532 | Const minDate As Date = #1/1/100# 533 | Const maxDate As Date = #12/31/9999# 534 | ' 535 | Dim dt As Date 536 | Dim i As Long, j As Long 537 | Dim d As Double 538 | Dim s As String 539 | ' 540 | For i = minDate To maxDate Step 200 541 | d = CDbl(i) 'No time added 542 | MemDate(VarPtr(dt)) = d 543 | Debug.Assert dt = d 544 | For j = 1 To 100 545 | d = CDbl(i) + Rnd() 'Add some random time (hh:mm:ss) 546 | MemDate(VarPtr(dt)) = d 547 | Debug.Assert dt = d 548 | Next j 549 | Next i 550 | ' 551 | d = CDbl(minDate) - 5000 'Invalid date 552 | MemDate(VarPtr(dt)) = MemDate(VarPtr(d)) 553 | Debug.Assert dt + 5000 = minDate 554 | ' 555 | On Error Resume Next 556 | s = CStr(dt) 557 | Debug.Assert Err.Number = 5 'Invalid date 558 | On Error GoTo 0 559 | ' 560 | d = CDbl(maxDate) + 50000 561 | MemDate(VarPtr(dt)) = MemDate(VarPtr(d)) 562 | Debug.Assert dt - 50000 = maxDate 563 | ' 564 | On Error Resume Next 565 | s = CStr(dt) 566 | Debug.Assert Err.Number = 5 567 | On Error GoTo 0 568 | End Sub 569 | 570 | Private Sub TestReadDouble() 571 | Dim d As Double 572 | Dim v As Variant 573 | ' 574 | For Each v In Array(-1.79769313486231E+308, -4.94065645841247E-324, 0 _ 575 | , 4.94065645841247E-324, 1.79769313486231E+308) 576 | d = v 577 | Debug.Assert MemDbl(VarPtr(d)) = d 578 | Next v 579 | ' 580 | #If Win64 Then 581 | Debug.Assert MemDbl(VarPtr(&H7FF0000000000000^)) = PosInf() 582 | Debug.Assert MemDbl(VarPtr(&HFFF0000000000000^)) = NegInf() 583 | Debug.Assert CStr(MemDbl(VarPtr(&HFFF8000000000000^))) = CStr(SNAN()) 584 | Debug.Assert CStr(MemDbl(VarPtr(&H7FF8000000000000^))) = CStr(QNAN()) 585 | ' 586 | Dim ll As LongLong 587 | Const loopStep As LongLong = &H1000000000000^ 588 | ' 589 | ll = &H8000000000000000^ 590 | Do 591 | If (ll And &H7FF0000000000000^) <> &H7FF0000000000000^ Then 'Skip INF/NAN 592 | Debug.Assert MemDbl(VarPtr(ll)) = LongLongToDouble(ll) 593 | End If 594 | ll = ll + loopStep 595 | Loop Until ll > &H7FFFFFFFFFFFFFFF^ - loopStep 596 | #End If 597 | End Sub 598 | 599 | #If Win64 Then 600 | Private Function LongLongToDouble(ByVal ll As LongLong) As Double 601 | Dim signBit As Long 602 | Dim exponentBits As Long 603 | Dim fractionBits As Double 604 | Dim i As Long 605 | ' 606 | signBit = IIf(ll And &H8000000000000000^, -1, 1) 607 | For i = 52 To 62 608 | exponentBits = exponentBits - CBool(ll And 2 ^ i) * 2 ^ (i - 52) 609 | Next i 610 | For i = 1 To 52 611 | fractionBits = fractionBits - CBool(ll And 2 ^ (52 - i)) * 2 ^ -i 612 | Next i 613 | If exponentBits = 0 Then 614 | If fractionBits <> 0 Then exponentBits = -1022 615 | ElseIf exponentBits = 2047 Then 616 | If fractionBits = 0 Then 617 | LongLongToDouble = PosInf() 618 | Else 619 | LongLongToDouble = SNAN() 620 | End If 621 | If signBit = -1 Then LongLongToDouble = -LongLongToDouble 622 | Exit Function 623 | Else 624 | Const bias As Long = 1023 625 | exponentBits = exponentBits - bias 626 | fractionBits = fractionBits + 1 627 | End If 628 | LongLongToDouble = signBit * 2 ^ exponentBits * fractionBits 629 | End Function 630 | #End If 631 | 632 | Private Sub TestWriteDouble() 633 | Dim d As Double, d2 As Double 634 | Dim v As Variant 635 | ' 636 | For Each v In Array(-1.79769313486231E+308, -4.94065645841247E-324, 0 _ 637 | , 4.94065645841247E-324, 1.79769313486231E+308) 638 | MemDbl(VarPtr(d)) = v 639 | Debug.Assert d = v 640 | Next v 641 | ' 642 | #If Win64 Then 643 | Dim ll As LongLong 644 | ' 645 | MemDbl(VarPtr(ll)) = PosInf() 646 | Debug.Assert ll = &H7FF0000000000000^ 647 | ' 648 | MemDbl(VarPtr(ll)) = NegInf() 649 | Debug.Assert ll = &HFFF0000000000000^ 650 | ' 651 | MemDbl(VarPtr(ll)) = SNAN() 652 | Debug.Assert ll = &HFFF8000000000000^ 653 | ' 654 | MemDbl(VarPtr(ll)) = QNAN() 655 | Debug.Assert ll = &H7FF8000000000000^ 656 | ' 657 | Const loopStep As LongLong = &H1000000000000^ 658 | ' 659 | ll = &H8000000000000000^ 660 | Do 661 | If (ll And &H7FF0000000000000^) <> &H7FF0000000000000^ Then 'Skip INF/NAN 662 | d = LongLongToDouble(ll) 663 | MemDbl(VarPtr(d2)) = d 664 | Debug.Assert d = d2 665 | End If 666 | ll = ll + loopStep 667 | Loop Until ll > &H7FFFFFFFFFFFFFFF^ - loopStep 668 | #End If 669 | End Sub 670 | 671 | Private Sub TestMemCopy() 672 | Dim arr1() As Byte 673 | Dim arr2() As Byte 674 | Dim i As Long, j As Long 675 | ' 676 | ReDim arr1(0 To 2 ^ 24) 677 | arr2 = arr1 678 | ' 679 | For i = LBound(arr2) To UBound(arr2) 680 | arr2(i) = i Mod 256 681 | Next i 682 | ' 683 | For i = LBound(arr2) To 2 ^ 13 684 | MemCopy VarPtr(arr1(0)), VarPtr(arr2(0)), i + 1 685 | For j = 0 To i 686 | Debug.Assert arr1(j) = arr2(j) 687 | arr1(j) = 0 'Clear for next run 688 | Next j 689 | Next i 690 | ' 691 | For i = 2 ^ 13 To 2 ^ 18 Step 2 ^ 6 - 1 692 | MemCopy VarPtr(arr1(0)), VarPtr(arr2(0)), i + 1 693 | For j = 0 To i Step 2 ^ 6 - 1 694 | Debug.Assert arr1(j) = arr2(j) 695 | arr1(j) = 0 'Clear for next run 696 | Next j 697 | Next i 698 | ' 699 | For i = 2 ^ 18 To 2 ^ 24 Step 2 ^ 16 - 1 700 | MemCopy VarPtr(arr1(0)), VarPtr(arr2(0)), i + 1 701 | For j = 0 To i Step 2 ^ 10 - 1 702 | Debug.Assert arr1(j) = arr2(j) 703 | arr1(j) = 0 'Clear for next run 704 | Next j 705 | Next i 706 | ' 707 | #If Win64 Then 708 | ReDim arr1(0 To 2 ^ 31 - 2) 709 | #Else 710 | ReDim arr1(0 To 2 ^ 27 - 1) 711 | #End If 712 | arr2 = arr1 713 | ' 714 | For i = LBound(arr2) To UBound(arr2) - 2 ^ 16 Step 2 ^ 16 - 1 715 | arr2(i) = i Mod 256 716 | Next i 717 | arr2(UBound(arr2) - 1) = 55 718 | ' 719 | MemCopy VarPtr(arr1(0)), VarPtr(arr2(0)), UBound(arr2) 720 | For i = LBound(arr2) To UBound(arr2) - 2 ^ 16 Step 2 ^ 16 - 1 721 | Debug.Assert arr1(i) = arr2(i) 722 | Next i 723 | Debug.Assert arr1(UBound(arr1) - 1) = 55 724 | ' 725 | 'Test overlap 726 | ReDim arr1(0 To 100) 727 | For i = 0 To 100 728 | arr1(i) = i 729 | Next i 730 | MemCopy VarPtr(arr1(10)), VarPtr(arr1(0)), 50 731 | For i = 0 To 9 732 | Debug.Assert arr1(i) = i 733 | Next i 734 | For i = 10 To 59 735 | Debug.Assert arr1(i) = i - 10 736 | Next i 737 | For i = 60 To 100 738 | Debug.Assert arr1(i) = i 739 | Next i 740 | ' 741 | For i = 0 To 100 742 | arr1(i) = i 743 | Next i 744 | MemCopy VarPtr(arr1(10)), VarPtr(arr1(13)), 50 745 | For i = 0 To 9 746 | Debug.Assert arr1(i) = i 747 | Next i 748 | For i = 10 To 59 749 | Debug.Assert arr1(i) = i + 3 750 | Next i 751 | For i = 60 To 100 752 | Debug.Assert arr1(i) = i 753 | Next i 754 | ' 755 | For i = 0 To 100 756 | arr1(i) = i 757 | Next i 758 | MemCopy VarPtr(arr1(10)), VarPtr(arr1(7)), 50 759 | For i = 0 To 9 760 | Debug.Assert arr1(i) = i 761 | Next i 762 | For i = 10 To 59 763 | Debug.Assert arr1(i) = i - 3 764 | Next i 765 | For i = 60 To 100 766 | Debug.Assert arr1(i) = i 767 | Next i 768 | ' 769 | For i = 0 To 100 770 | arr1(i) = i 771 | Next i 772 | MemCopy VarPtr(arr1(10)), VarPtr(arr1(1)), 50 773 | For i = 0 To 9 774 | Debug.Assert arr1(i) = i 775 | Next i 776 | For i = 10 To 59 777 | Debug.Assert arr1(i) = i - 9 778 | Next i 779 | For i = 60 To 100 780 | Debug.Assert arr1(i) = i 781 | Next i 782 | ' 783 | For i = 0 To 100 784 | arr1(i) = i 785 | Next i 786 | MemCopy VarPtr(arr1(10)), VarPtr(arr1(15)), 50 787 | For i = 0 To 9 788 | Debug.Assert arr1(i) = i 789 | Next i 790 | For i = 10 To 59 791 | Debug.Assert arr1(i) = i + 5 792 | Next i 793 | For i = 60 To 100 794 | Debug.Assert arr1(i) = i 795 | Next i 796 | ' 797 | For i = 0 To 100 798 | arr1(i) = i 799 | Next i 800 | MemCopy VarPtr(arr1(10)), VarPtr(arr1(27)), 50 801 | For i = 0 To 9 802 | Debug.Assert arr1(i) = i 803 | Next i 804 | For i = 10 To 59 805 | Debug.Assert arr1(i) = i + 17 806 | Next i 807 | For i = 60 To 100 808 | Debug.Assert arr1(i) = i 809 | Next i 810 | End Sub 811 | 812 | Private Sub TestCloneParamArray() 813 | Dim i1 As Long: i1 = 1 814 | Dim i2 As Long: i2 = 2 815 | Dim d As Double: d = 2.25 816 | Dim s1 As String: s1 = "ABC" 817 | Dim s2 As String: s2 = "DEF" 818 | Dim v1 As Variant: v1 = "ABC" 819 | Dim v2 As Variant: Set v2 = New Collection 820 | Dim v3 As Variant: v3 = Null 821 | Dim o1 As Object: Set o1 = New Collection 822 | Dim o2 As Collection: Set o2 = Nothing 823 | Dim arr() As Variant 824 | ' 825 | TestParamArray i1, (i2), 1, d, 2.2, "ABC", s1, (s2), v1, v2, New Collection, v3, o1, o2, Null, Nothing, arr, Array(1, 2, 3) 826 | ' 827 | Debug.Assert i1 = 2 828 | Debug.Assert i2 = 2 829 | Debug.Assert d = 3.14 830 | Debug.Assert s1 = "GHI" 831 | Debug.Assert s2 = "DEF" 832 | Debug.Assert v1 = 777 833 | Debug.Assert v2 Is Nothing 834 | Debug.Assert v3 Is Nothing 835 | Debug.Assert o1 Is Application 836 | Debug.Assert o2.Count = 1 837 | Debug.Assert UBound(arr) - LBound(arr) + 1 = 3 838 | Debug.Assert arr(UBound(arr)) = "ABC" 839 | End Sub 840 | Private Sub TestParamArray(ParamArray args() As Variant) 841 | Dim arr() As Variant 842 | CloneParamArray Not Not args, arr 843 | 844 | LetSet(arr(0)) = 2 845 | LetSet(arr(1)) = 3 846 | LetSet(arr(2)) = 4 847 | LetSet(arr(3)) = 3.14 848 | LetSet(arr(4)) = "2.2" 849 | LetSet(arr(5)) = 2.2 850 | LetSet(arr(6)) = "GHI" 851 | LetSet(arr(7)) = "ABC" 852 | LetSet(arr(8)) = 777 853 | LetSet(arr(9)) = Nothing 854 | LetSet(arr(10)) = Null 855 | LetSet(arr(11)) = Nothing 856 | LetSet(arr(12)) = Application 857 | LetSet(arr(13)) = New Collection: arr(13).Add Empty 858 | LetSet(arr(14)) = Empty 859 | LetSet(arr(15)) = Array(1, 2, 3) 860 | LetSet(arr(16)) = Array(1, 2, "ABC") 861 | LetSet(arr(17)) = Null 862 | End Sub 863 | Private Property Let LetSet(ByRef result As Variant, ByRef v As Variant) 864 | If IsObject(v) Then Set result = v Else result = v 865 | End Property 866 | 867 | Private Sub TestStringToIntegers() 868 | Dim arr() As Integer 869 | ' 870 | arr = StringToIntegers("ABC") 871 | Debug.Assert arr(0) = AscW("A") 872 | Debug.Assert arr(1) = AscW("B") 873 | Debug.Assert arr(2) = AscW("C") 874 | ' 875 | arr = StringToIntegers("ABC", outLowBound:=5) 876 | Debug.Assert arr(5) = AscW("A") 877 | Debug.Assert arr(6) = AscW("B") 878 | Debug.Assert arr(7) = AscW("C") 879 | ' 880 | arr = StringToIntegers("ABC", 2, , 5) 881 | Debug.Assert arr(5) = AscW("B") 882 | Debug.Assert arr(6) = AscW("C") 883 | On Error Resume Next 884 | Dim i As Integer: i = arr(7) 885 | #If TWINBASIC Then 886 | Debug.Assert Err.Number <> 0 887 | #Else 888 | Debug.Assert Err.Number = 9 889 | #End If 890 | On Error GoTo 0 891 | ' 892 | arr = StringToIntegers("ABC", 2, 7, 5) 893 | Debug.Assert arr(5) = AscW("B") 894 | Debug.Assert arr(6) = AscW("C") 895 | ' 896 | arr = StringToIntegers("ABC", 2, 0, 5) 897 | Debug.Assert LBound(arr) = 5 898 | Debug.Assert UBound(arr) = 4 899 | ' 900 | arr = StringToIntegers(vbNullString, 2, 0, 5) 901 | Debug.Assert LBound(arr) = 5 902 | Debug.Assert UBound(arr) = 4 903 | ' 904 | arr = StringToIntegers(vbNullString) 905 | Debug.Assert UBound(arr) - LBound(arr) + 1 = 0 906 | ' 907 | arr = StringToIntegers(StrConv("ABC", vbFromUnicode)) 908 | Debug.Assert arr(0) = Asc("A") + Asc("B") * &H100 909 | End Sub 910 | 911 | Private Sub TestIntegersToString() 912 | Dim arr() As Integer 913 | Dim s As String 914 | ' 915 | On Error Resume Next 916 | s = IntegersToString(arr) 917 | Debug.Assert Err.Number = 5 918 | On Error GoTo 0 919 | ' 920 | ReDim arr(0 To 0): arr(0) = Asc("A") 921 | Debug.Assert IntegersToString(arr) = "A" 922 | ' 923 | ReDim Preserve arr(0 To 1) 924 | Debug.Assert IntegersToString(arr) = "A" & vbNullChar 925 | Debug.Assert IntegersToString(arr, 5) = vbNullString 926 | Debug.Assert IntegersToString(arr, 1) = vbNullChar 927 | Debug.Assert IntegersToString(arr, 1, -1) = vbNullChar 928 | Debug.Assert IntegersToString(arr, 1, 2) = vbNullChar 929 | Debug.Assert IntegersToString(arr, 1, 0) = vbNullString 930 | End Sub 931 | 932 | Private Sub TestEmptyArray() 933 | Dim arr As Variant 934 | Dim v As Variant 935 | Dim i As Long 936 | ' 937 | For Each v In Array(vbByte, vbInteger, vbLong, vbLongLong, vbCurrency, vbDecimal, vbDouble, vbSingle, vbDate, vbBoolean, vbString, vbObject, vbDataObject, vbVariant) 938 | For i = 1 To 60 939 | arr = EmptyArray(i, v) 940 | Debug.Assert VarType(arr) = vbArray + v 941 | Debug.Assert GetArrayDimsCount(arr) = i 942 | Next i 943 | Next v 944 | ' 945 | On Error Resume Next 946 | arr = EmptyArray(61, vbBoolean) 947 | Debug.Assert Err.Number = 5 948 | On Error GoTo 0 949 | ' 950 | On Error Resume Next 951 | arr = EmptyArray(2, 500) 952 | Debug.Assert Err.Number = 13 953 | On Error GoTo 0 954 | End Sub 955 | Private Function GetArrayDimsCount(ByRef arr As Variant) As Long 956 | Const MAX_DIMENSION As Long = 60 'VB limit 957 | Dim dimension As Long 958 | Dim tempBound As Long 959 | ' 960 | On Error GoTo FinalDimension 961 | For dimension = 1 To MAX_DIMENSION 962 | tempBound = LBound(arr, dimension) 963 | Next dimension 964 | FinalDimension: 965 | GetArrayDimsCount = dimension - 1 966 | End Function 967 | 968 | Private Sub TestMemFill() 969 | Dim arr() As Byte 970 | Dim i As Long, j As Long 971 | Const maxTestSize As Long = 2 ^ 24 ' Can increase but will take longer to run 972 | Dim size As Long 973 | Dim stepSize As Long 974 | Dim b As Byte 975 | ' 976 | ReDim arr(1 To maxTestSize) 977 | size = 1 978 | ' 979 | For i = 1 To 2 ^ 10 980 | b = i Mod 256 981 | MemFill VarPtr(arr(1)), i, b 982 | For j = 1 To i 983 | Debug.Assert arr(j) = b 984 | Next j 985 | For j = i + 1 To i * 2 986 | Debug.Assert arr(j) = 0 987 | Next j 988 | Next i 989 | ' 990 | stepSize = 2 ^ 12 + 1 991 | For i = 2 ^ 14 To 2 ^ 18 Step stepSize 992 | b = i Mod 256 993 | MemFill VarPtr(arr(1)), i, b 994 | For j = 1 To i 995 | Debug.Assert arr(j) = b 996 | Next j 997 | For j = i + 1 To i * 2 998 | Debug.Assert arr(j) = 0 999 | Next j 1000 | Next i 1001 | ' 1002 | b = 5 1003 | MemFill VarPtr(arr(1)), maxTestSize, b 1004 | For i = 1 To maxTestSize 1005 | Debug.Assert arr(i) = b 1006 | Next i 1007 | ' 1008 | MemFill VarPtr(arr(1000)), 1000, 7 1009 | For i = 1 To 999 1010 | Debug.Assert arr(i) = b 1011 | Next i 1012 | For i = 1000 To 1999 1013 | Debug.Assert arr(i) = 7 1014 | Next i 1015 | For i = 2000 To maxTestSize 1016 | Debug.Assert arr(i) = b 1017 | Next i 1018 | End Sub 1019 | --------------------------------------------------------------------------------