Ok, this is an idea I've been playing around with, inspired by some work by Dilettante and The Trick. And much thanks goes out to both of them.
My idea was to use those concepts and create a class that "looks like" an array (of any numeric data type of your choosing). The primary feature this will have that other typical VB6 arrays don't have is that the data is stored in far memory. These arrays can expand past our 2GB (or 4GB with LAA) VB6 limitations. It's a single class module that you can include into any project. Furthermore, you can instantiate it as many times as you like to create as many far memory arrays as you like.
Furthermore, because this is in far memory, you can actually use it as a way to communicate across processes (so long as you know the "name" of the memory file that you're using). See documentation in the class for more information on this. And, just as an FYI, these far memory files hang around so long as one process has a file handle opened against it. When the last handle is closed, the file is purged from far memory.
Also, don't let the nomenclature of "file" confuse you. These are memory files, not disk based files, other than the possibility that the data may get pushed into the OS's paging virtual memory if you ask for more memory than is available in your computer. And, if this happens, these things will perform much slower than when this doesn't happen.
One CAVEAT about these things. When developing in the IDE, it's not the best idea to use the "Stop" button when you've got one (or more) copies of the MemoryBasedArray.cls array instantiated. The reason is, once you call the Initialize procedure within that class, you have a far memory file open. And it's the Class_Terminate event that closes that file. If you don't explicitly close it, even when returning to IDE development mode, that file will stay open. There's no great harm in this, and it won't crash the IDE. However, the next time you execute your program, you will probably get a "File Already Open" error. And then, the only way to clear that error is to close the IDE and re-open it.
What types of arrays will this thing store? It will store any of the VB6 intrinsic types: vbByte, vbBoolean, vbInteger, vbLong, vbSingle, vbCurrency, vbDate, vbDouble, & vbDecimal.
Notice that even vbDecimal is included in that list. The entire Variant (holding a Decimal) is stored in that case, all 16 bytes.
There is also a vbString option/specification. These aren't exactly BSTR strings nor fixed-length-strings. They're better thought of as similar to fixed database fields specified to hold Unicode strings. Also, there are some criteria for these things ... primarily that they can't have vbNullChar values in the trailing characters of the string. The vbNullChar is used for padding within the buffer. And, when these strings are returned, they're right-trimmed for vbNullChar. So long as the trailing character of an input string isn't vbNullChar, they can contain other vbNullChar values with no problem.
Also, the Value (both Let & Get) property of this class is the default, so, once instantiated and initialized, you can use it like a true array (with the index and value).
There is a "test" project attached. I've also shown the code of the class, but you're better off to get the class out of the test project. As, that way, the Value property will stay the default property.
Code:
' Ideas herein were inspired by some work that Dilettante & The Trick (vbforums.com) have done.
'
' With this class, you can create an array that uses "far" memory,
' and isn't limited to the 2GB (or 4GB with LAA) that VB6 is limited to.
'
' Initialize must be called immediately after instantiation.
' Then, the Value property (Get & Let) can be used.
'
Option Explicit
'
Private Type SYSTEM_INFO
Reserved1(27&) As Byte
dwAllocationGranularity As Long ' For purposes herein, this is all we need.
Reserved2(3&) As Byte
End Type
'
Private Declare Function CreateFileMapping Lib "kernel32" Alias "CreateFileMappingA" (ByVal hFile As Long, ByVal lpFileMappigAttributes As Long, ByVal flProtect As Long, ByVal dwMaximumSizeHigh As Long, ByVal dwMaximumSizeLow As Long, ByVal lpName As String) As Long
Private Declare Function MapViewOfFile Lib "kernel32" (ByVal hFileMappingObject As Long, ByVal dwDesiredAccess As Long, ByVal dwFileOffsetHigh As Long, ByVal dwFileOffsetLow As Long, ByVal dwNumberOfBytesToMap As Long) As Long
Private Declare Function OpenFileMapping Lib "kernel32" Alias "OpenFileMappingA" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As String) As Long
Private Declare Function UnmapViewOfFile Lib "kernel32" (ByVal lpBaseAddress As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Long, ByRef Source As Long, ByVal Length As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (ByRef Destination As Long, ByVal Length As Long)
Private Declare Sub GetSystemInfo Lib "kernel32" (ByRef lpSystemInfo As SYSTEM_INFO)
Private Declare Function VariantChangeType Lib "oleaut32" (Dest As Variant, src As Variant, ByVal wFlags As Integer, ByVal vt As Long) As Long
'
Private mbInit As Boolean
Private mhMemFile As Long
Private miVarType As Long
Private miItemBytes As Long
Private mvMaxCount As Variant ' Decimal.
Private miVariantOffset As Long
Private miGranularity As Long
'
Private mpMapView As Long
Private mdwViewHigh As Long
Private mdwViewLow As Long
'
Public Sub Initialize(ByRef sUniqueName As String, iVarType As VBA.VbVarType, iMaxItemCount As Variant, Optional iFixedStringCharLen As Long = 10&, Optional bOpenOnlyNoCreate As Boolean = False)
'
' sUniqueName is a system-wide thing. If other programs are using CreateFileMapping,
' the sUniqueName must be unique with respect to those, and not only names used within this project.
'
' iVarType is simply the variable type you'll be storing in this array.
' Or, fixed length strings (not the same as VB6's fixed length strings) are allowed.
'
' iMaxItemCount is the maximum (not necessily used) number of items in the array.
' You will get an error if you overflow this when using the Value properties.
' Note that far memory is allocated based on this iMaxItemCount argument.
' This iMaxItemCount must be a numeric integer. It's not a Long so that even more than a Long's limits can be used.
'
' If iVarType = vbString then iFixedStringCharLen is examined for how long they should be.
' As a note, these strings CAN'T end in vbNullChar, as that's reserved for padding in these things.
' Also, their length must an integer divisor of the system's granularity (typically some power of 2).
'
If mbInit Then Exit Sub ' Only allow this to be called once.
If Not IsNumeric(iMaxItemCount) Then Err.Raise 13&, TypeName(Me), "iMaxItemCount must be numeric."
If iMaxItemCount < 1& Then Err.Raise 5&, TypeName(Me), "Count must be at least 1."
'
' Save granularity.
miGranularity = MemAllocGranularity
'
' The only allowed types are: vbBoolean, vbByte, vbCurrency, vbDate, vbDecimal, vbDouble, vbInteger, vbLong, vbSingle, or vbString.
Select Case iVarType
Case vbByte: miItemBytes = 1&: miVariantOffset = 8& ' These are the length (bytes) and offset with a variant for our data types.
Case vbBoolean, vbInteger: miItemBytes = 2&: miVariantOffset = 8& ' In most cases (all but Decimal), a variant stores data at an 8 byte offset.
Case vbLong, vbSingle: miItemBytes = 4&: miVariantOffset = 8&
Case vbCurrency, vbDate, vbDouble: miItemBytes = 8&: miVariantOffset = 8&
Case vbDecimal: miItemBytes = 16&: miVariantOffset = 0& ' This is the one case where all 14 bytes of the variant's data are used.
Case vbString
' This one needs a bit of special handling.
miItemBytes = iFixedStringCharLen * 2& ' Unicode.
Select Case True
Case miGranularity < miItemBytes
Err.Raise 6&, TypeName(Me), "Fixed string length (" & CStr(iFixedStringCharLen) & ") overflow. They can't be longer than the system's granularity / 2 (" & CStr(miGranularity / 2) & ")."
Case iFixedStringCharLen < 1&
Err.Raise 6&, TypeName(Me), "Fixed string length underflow. Length: " & CStr(iFixedStringCharLen)
Case miGranularity Mod miItemBytes <> 0
Err.Raise 6&, TypeName(Me), "Fixed string length * 2 (for Unicode) (" & CStr(iFixedStringCharLen) & ") not an even divisor of the system's granularity (" & CStr(miGranularity) & ")."
End Select
'
miVariantOffset = 8& ' But, in this case, it's the BSTR pointer.
Case Else: Err.Raise 13&, TypeName(Me), "Invalid variable type specified."
End Select
'
' Save our initialization properties.
miVarType = iVarType
mvMaxCount = CDec(iMaxItemCount)
'
' Figure out byte size of Mapped File, and round UP to a multiple of MemAllocGranularity.
Dim vTotalBytes As Variant
vTotalBytes = CDec(miItemBytes) * mvMaxCount
vTotalBytes = Int((vTotalBytes - CDec(1&) + CDec(miGranularity)) / CDec(miGranularity)) * CDec(miGranularity)
'
' Copy low and high into MapViewOfFile offset arguments.
Dim dwMaximumSizeHigh As Long
Dim dwMaximumSizeLow As Long
'
' Variant structure with a Decimal.
' VariantType As Integer ' Reserved, to act as the Variant Type when sitting in a 16-Byte-Variant. Equals vbDecimal(14) when it's a Decimal type.
' Base10NegExp As Byte ' Base 10 exponent (0 to 28), moving decimal to right (smaller numbers) as this value goes higher. Top three bits are never used.
' sign As Byte ' Sign bit only. Other bits aren't used.
' Hi32 As Long ' Mantissa.
' Lo32 As Long ' Mantissa.
' Mid32 As Long ' Mantissa.
CopyMemory dwMaximumSizeHigh, ByVal PtrAdd(VarPtr(vTotalBytes), 12&), 4& ' Mid32
CopyMemory dwMaximumSizeLow, ByVal PtrAdd(VarPtr(vTotalBytes), 8&), 4& ' Lo32
'
' Create our memory file.
Const INVALID_HANDLE_VALUE As Long = -1&
Const PAGE_READWRITE As Long = 4&
Const FILE_MAP_WRITE As Long = 2&
Const FILE_MAP_READ As Long = 4&
'
If Not bOpenOnlyNoCreate Then
mhMemFile = CreateFileMapping(INVALID_HANDLE_VALUE, 0&, PAGE_READWRITE, dwMaximumSizeHigh, dwMaximumSizeLow, sUniqueName)
If mhMemFile = 0& Then
If Err.LastDllError = 1450& Then
Err.Raise Err.LastDllError, TypeName(Me), "CreateFileMapping error ERROR_NO_SYSTEM_RESOURCES. This probably means you don't have enough memory in this computer to map file(s) as large as you're trying to, or maybe memory is full with other executing programs."
Else
Err.Raise Err.LastDllError, TypeName(Me), "CreateFileMapping API system error."
End If
End If
'
Const ERROR_ALREADY_EXISTS As Long = 183&
If Err.LastDllError = ERROR_ALREADY_EXISTS Then CloseMemFile: Err.Raise 55&, TypeName(Me), sUniqueName & " already open."
Else
mhMemFile = OpenFileMapping(FILE_MAP_READ + FILE_MAP_WRITE, 0&, sUniqueName)
If mhMemFile = 0& Then Err.Raise Err.LastDllError, TypeName(Me), "OpenFileMapping API system error. Make sure the file exists."
End If
'
' All done and ready to be used.
mbInit = True
End Sub
Private Sub Class_Terminate()
' When all handles to the mapped object are closed, it disappears.
' When in the IDE, abnormal termination can leave the file open,
' and only way to get rid of it is to restart the IDE.
' When compiled, it's not a problem.
'
CloseMemFile
End Sub
Private Sub CloseMemFile()
If mpMapView Then
ApiZ UnmapViewOfFile(mpMapView)
mpMapView = 0&
End If
If mhMemFile Then
ApiZ CloseHandle(mhMemFile)
mhMemFile = 0&
End If
End Sub
Public Property Let Value(index As Variant, vValue As Variant)
' Zero based index. It can be any numeric value, but will always be treated as an integer,
' and internally, it'll be handled as a Decimal.
'
' If you need an index larger than 2147483647 (&h7fffffff), you can cast a string to a decimal
' using something like: CDec("99999999999"), or just use Decimal types in the first place for your indices.
'
If Not mbInit Then Exit Property
'
' Make sure we've got valid arguments.
If VarType(vValue) <> miVarType Then CloseMemFile: Err.Raise 13&, TypeName(Me), "Value type doesn't match initialization type: " & TypeName(vValue)
Dim vDecIdx As Variant
vDecIdx = ValidateIndex(index)
'
' Create a map view of our memory file.
Dim iGranOffset As Long
iGranOffset = CreateSingleItemMapping(vDecIdx)
'
' Put data into memory mapped file.
If miVarType <> vbString Then
CopyMemory ByVal PtrAdd(mpMapView, iGranOffset), ByVal PtrAdd(VarPtr(vValue), miVariantOffset), miItemBytes
Else
ZeroMemory ByVal PtrAdd(mpMapView, iGranOffset), miItemBytes
Dim iChars As Long
iChars = miItemBytes \ 2&
Dim s As String
s = String$(iChars, vbNullChar) ' Create a buffer.
Mid$(s, 1&, Len(vValue)) = vValue ' s is now padded with vbNullChar if necessary.
CopyMemory ByVal PtrAdd(mpMapView, iGranOffset), ByVal StrPtr(s), miItemBytes ' We ignore the BSTR zero terminator.
End If
End Property
Public Property Get Value(index As Variant) As Variant
' Zero based index. See notes in "Let Value" property.
'
If Not mbInit Then Exit Property
'
' Make sure we've got valid arguments.
Dim vDecIdx As Variant
vDecIdx = ValidateIndex(index)
'
' Create a map view of our memory file.
Dim iGranOffset As Long
iGranOffset = CreateSingleItemMapping(vDecIdx)
'
' Get data from memory mapped file.
If miVarType <> vbString Then
Value = CLng(0&)
If miVarType <> vbLong Then ApiE VariantChangeType(Value, Value, 0&, miVarType), "VariantChangeType" ' Make our variant the correct type.
CopyMemory ByVal PtrAdd(VarPtr(Value), miVariantOffset), ByVal PtrAdd(mpMapView, iGranOffset), miItemBytes
Else ' Handle strings.
Dim iChars As Long
iChars = miItemBytes \ 2&
Dim ia() As Integer
ReDim ia(1& To iChars) ' Create a buffer.
CopyMemory ByVal VarPtr(ia(1&)), ByVal PtrAdd(mpMapView, iGranOffset), miItemBytes
' Need to trim null characters (from end).
Dim i As Long
For i = UBound(ia) To 1& Step -1&
If ia(i) Then Exit For ' We found something non-zero.
Next
If i Then ' If it wound down to 0, then it was all zeroes.
Dim s As String
s = Space$(i)
CopyMemory ByVal StrPtr(s), ByVal VarPtr(ia(1&)), i * 2& ' Unicode.
Value = s
Else
Value = vbNullString
End If
End If
End Property
Private Function ValidateIndex(index As Variant) As Variant ' vDecIdx is returned.
If Not IsNumeric(index) Then CloseMemFile: Err.Raise 9&, TypeName(Me), "Bad index type: " & TypeName(index)
Dim vDecIdx As Variant
vDecIdx = CDec(index)
If vDecIdx < 0& Or (vDecIdx + 1&) > mvMaxCount Then CloseMemFile: Err.Raise 9&, TypeName(Me), "Bad index range: " & CStr(vDecIdx)
If vDecIdx <> Int(vDecIdx) Then CloseMemFile: Err.Raise 9&, TypeName(Me), "Bad index value: " & CStr(vDecIdx)
'
ValidateIndex = vDecIdx
End Function
Private Function CreateSingleItemMapping(ByVal vDecIdx As Variant) As Long
' The iGranOffset is returned, which is an offset in the "View" to the specific item requested.
' mpMapView is also set.
'
' Convert vDecIdx into a byte offset.
vDecIdx = vDecIdx * CDec(miItemBytes)
'
' Calculate an offset that appreciates granularity.
Dim vTemp As Variant
vTemp = Int(vDecIdx / CDec(miGranularity)) ' Rounds down, preserving Decimal type.
vTemp = vTemp * CDec(miGranularity) ' This can now be used in MapViewOfFile API call.
CreateSingleItemMapping = vDecIdx - vTemp ' This provides an offset for addressing a single item.
'
' Copy low and high into MapViewOfFile offset arguments.
Dim dwFileOffsetHigh As Long
Dim dwFileOffsetLow As Long
'
' Variant structure with a Decimal.
' VariantType As Integer ' Reserved, to act as the Variant Type when sitting in a 16-Byte-Variant. Equals vbDecimal(14) when it's a Decimal type.
' Base10NegExp As Byte ' Base 10 exponent (0 to 28), moving decimal to right (smaller numbers) as this value goes higher. Top three bits are never used.
' sign As Byte ' Sign bit only. Other bits aren't used.
' Hi32 As Long ' Mantissa.
' Lo32 As Long ' Mantissa.
' Mid32 As Long ' Mantissa.
CopyMemory dwFileOffsetHigh, ByVal PtrAdd(VarPtr(vTemp), 12&), 4& ' Mid32
CopyMemory dwFileOffsetLow, ByVal PtrAdd(VarPtr(vTemp), 8&), 4& ' Lo32
'
' Make sure we need to do something.
If mpMapView = 0& Or mdwViewHigh <> dwFileOffsetHigh Or mdwViewLow <> dwFileOffsetLow Then
If mpMapView Then ApiZ UnmapViewOfFile(mpMapView)
mdwViewHigh = 0&
mdwViewLow = 0&
'
' Create a mapview of our memory file.
Const FILE_MAP_WRITE = 2&
Const FILE_MAP_READ = 4&
mpMapView = MapViewOfFile(mhMemFile, FILE_MAP_READ + FILE_MAP_WRITE, dwFileOffsetHigh, dwFileOffsetLow, miGranularity)
If mpMapView = 0& Then CloseMemFile: Err.Raise Err.LastDllError, TypeName(Me), "MapViewOfFile system error."
'
mdwViewHigh = dwFileOffsetHigh
mdwViewLow = dwFileOffsetLow
End If
End Function
Private Function MemAllocGranularity() As Long
' When using MapViewOfFile, the quad_word offset must be a multiple of this granularity (per MSDN).
Dim si As SYSTEM_INFO
GetSystemInfo si
MemAllocGranularity = si.dwAllocationGranularity
End Function
Private Function PtrAdd(ByVal Ptr As Long, ByVal iOffset As Long) As Long
' For adding (or subtracting) a small number from a pointer.
PtrAdd = (Ptr Xor &H80000000) + iOffset Xor &H80000000
End Function
Private Function ApiZ(ApiReturn As Long, Optional sApiCall As String) As Long
' This one is for API calls that report error by returning ZERO.
'
If ApiReturn <> 0& Then
ApiZ = ApiReturn
Exit Function
End If
'
Dim sErr As String
If Len(sApiCall) Then
sErr = sApiCall & " error " & CStr(Err.LastDllError)
Else
sErr = "API Error " & CStr(Err.LastDllError)
End If
'
Dim InIDE As Boolean: Debug.Assert MakeTrue(InIDE)
If InIDE Then
Debug.Print sErr
Stop
Else
Err.Raise vbObjectError + 1147221504, TypeName(Me), sErr
End If
End Function
Private Sub ApiE(ApiReturn As Long, Optional sApiCall As String)
' Just a general error processing procedure for API errors.
' For API calls where 0& is OK.
'
If ApiReturn = 0& Then Exit Sub
'
Dim sErr As String
If Len(sApiCall) Then
sErr = sApiCall & " error " & CStr(ApiReturn)
Else
sErr = "API Error " & CStr(ApiReturn)
End If
'
Dim InIDE As Boolean: Debug.Assert MakeTrue(InIDE)
If InIDE Then
Debug.Print sErr
Stop
Else
Err.Raise vbObjectError + 1147221504 - ApiReturn, TypeName(Me), sErr
End If
End Sub
Private Function MakeTrue(ByRef b As Boolean) As Boolean
b = True
MakeTrue = True
End Function
---------------
In the thread where I was initially developing this, there was some discussion of putting UDTs into these things. Please see post #8 of this thread for an expanded discussion of this.
---------------
I've now tested in many ways, but here's the test code in the attached Form1. I've tested both the fixed length strings and the decimal type (both a bit unusual).
Code:
Option Explicit
'
Private Sub Form_Load()
Debug.Print
Debug.Print "********************************"
Debug.Print "String array test:"
Dim oStr As ArraysInFarMemory
Set oStr = New ArraysInFarMemory
oStr.Initialize "StrTest", vbString, 700000, 256&
'
oStr(0&) = "aaaa" ' Illustrating default property.
oStr.Value(1&) = "bbbbbbbbbbbb" ' Too long so it'll be truncated.
oStr.Value(2&) = vbNullString
oStr(300000) = "dddddddd" ' Illustrating default property.
Debug.Print "'"; oStr.Value(0&); "'"; " should be 'aaaa'"
Debug.Print "'"; oStr(1&); "'"; " should be 'bbbbbbbbbbbb'" ' Illustrates default property.
Debug.Print "'"; oStr.Value(2&); "'"; " should be empty"
Debug.Print "'"; oStr.Value(3&); "'"; " should be empty"
Debug.Print "'"; oStr.Value(4&); "'"; " should be empty"
Dim c As Long
For c = 1& To 500000
oStr(c) = CStr(c)
If oStr(c) <> CStr(c) Then Debug.Print "bad put/get": Stop
If c Mod 50000 = 0& Then Debug.Print CStr(c)
Next
Set oStr = Nothing
Debug.Print "Successfully stored and retrieved 500,000 string values,"
Debug.Print "verifying that they were stored correctly."
Debug.Print
Stop
Debug.Print
Debug.Print "********************************"
Debug.Print "Decimal array test:"
' We'll use the default property of the class for all of this work.
Dim oDec As ArraysInFarMemory
Set oDec = New ArraysInFarMemory
oDec.Initialize "DecimalTest", vbDecimal, 500000
oDec(0&) = CDec("987654321987654321987654321") ' Decimals can hold REALLY big numbers.
oDec(400000) = CDec("999888")
Debug.Print oDec(0&); " should be 987654321987654321987654321"
Debug.Print oDec(400000); " should be 999888"
Dim d As Long
For d = 0& To 490000
oDec(d) = CDec(d)
If oDec(d) <> CDec(d) Then Debug.Print "bad put/get": Stop
If d Mod 50000 = 0& Then Debug.Print CDec(d)
Next
Set oDec = Nothing
Debug.Print "Successfully stored and retrieved 490,000 decimal values,"
Debug.Print "verifying that they were stored correctly."
Debug.Print
Stop
Unload Me
End Sub
Notice I've put in some Stop commands, just so you can see what's going on. Again, be careful to not use the Stop "button" too much with this stuff, as you'll be reloading your IDE if you do, to clear the "File Already Open" error.
---------------
I look forward to any discussion anyone might like to have about this stuff. And a special thanks goes out to Eduardo who did some of the initial testing and found a bug in the vbString option.
Last edited by Elroy; Jul 4th, 2022 at 07:30 PM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Is there any way to tell if a UniqueName is already in use.
If it is, you'll get a "File Already Open" error when you try and create (call to Initialize) your array. And that's entirely independent of what process has that far memory file open. Best advice is just to use very unique file names. However, I doubt too many other things are using this stuff.
I suppose I could write a "test" function to test if a far memory file is already open. Would that be helpful?
ADDED: A thought though ... if you're writing some program and you'll allow multiple copies of that program to be simultaneously running, you'd better make sure each copy of the program will be using a different far memory file name, or they'll all be sharing the same far memory array. Actually, only the first one will run, and the others will get "File Already Open" errors.
Last edited by Elroy; Jul 4th, 2022 at 03:42 PM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
I just put it into a module named ArraysInFarMemory.bas:
Code:
Option Explicit
'
Private Declare Function CreateFileMapping Lib "kernel32" Alias "CreateFileMappingA" (ByVal hFile As Long, ByVal lpFileMappigAttributes As Long, ByVal flProtect As Long, ByVal dwMaximumSizeHigh As Long, ByVal dwMaximumSizeLow As Long, ByVal lpName As String) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'
Public Function FarMemoryFileExists(ByRef sUniqueName As String) As Boolean
'
' Just temporarily open our far memory file with one byte.
Dim hMemFile As Long
Const INVALID_HANDLE_VALUE As Long = -1&
Const PAGE_READWRITE As Long = 4&
hMemFile = CreateFileMapping(INVALID_HANDLE_VALUE, 0&, PAGE_READWRITE, 0&, 1&, sUniqueName)
'
' Save any error.
Dim iLastDllError As Long
iLastDllError = Err.LastDllError
'
' Close (clean up).
If hMemFile Then
If CloseHandle(hMemFile) = 0& Then Err.Raise Err.LastDllError, "FarMemoryFileExists", "CreateFileMapping API system error."
End If
'
' See if we got an unusual error.
If hMemFile = 0& Then
If iLastDllError = 1450& Then
Err.Raise iLastDllError, "FarMemoryFileExists", "CreateFileMapping error ERROR_NO_SYSTEM_RESOURCES. This probably means you don't have enough memory in this computer to map file(s) as large as you're trying to, or maybe memory is full with other executing programs."
Else
Err.Raise iLastDllError, "FarMemoryFileExists", "CreateFileMapping API system error."
End If
End If
'
' See if we got an already exists error, and put into return.
Const ERROR_ALREADY_EXISTS As Long = 183&
FarMemoryFileExists = iLastDllError = ERROR_ALREADY_EXISTS
End Function
I tested by putting in some debug stops into the test program (before and after the class was uninstantiated), and this FarMemoryFileExists function seemed to work perfectly.
Again, this can actually work from other processes, to see if some other process has a far memory file open.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Thanks a lot.
I already have something to entertain myself with
sorry for my language
No problem. Let me/us know if you use this thing and how it performs.
I'm hoping Eduardo will jump back in and do some performance testing of this thing. It certainly won't perform as fast as accessing typical arrays within our 32-bit address space, but it should be much faster than anything disk-based (so long as Windows paging doesn't kick in).
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
This is some code that can be used with the post #1 code that will allow UDTs to be converted to Strings that are compatible with the vbString arrays.
Code:
Option Explicit
'
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
'
Public Function StringFromUdtViaPtr(PtrToUdt As Long, LenBofUdt As Long, Optional bAppendNonZero As Boolean) As String
StringFromUdtViaPtr = String$((LenBofUdt + 1&) \ 2& + Abs(bAppendNonZero), vbNullChar)
If bAppendNonZero Then Mid$(StringFromUdtViaPtr, Len(StringFromUdtViaPtr), 1&) = vbLf ' Append ChrW$(&h10) to make sure it's not terminated in a vbNullChar.
CopyMemory ByVal StrPtr(StringFromUdtViaPtr), ByVal PtrToUdt, LenBofUdt ' On odd length UDTs, it won't completely fill the last Unicode character, but that's fine.
End Function
Public Sub UdtFromStringViaPtr(PtrToUdt As Long, LenBofUdt As Long, s As String, Optional bAppendNonZero As Boolean)
If Len(s) <> (LenBofUdt + 1&) \ 2& + Abs(bAppendNonZero) Then Err.Raise 13&, , "String isn't correct length for this UDT"
CopyMemory ByVal PtrToUdt, ByVal StrPtr(s), LenBofUdt
End Sub
There are a few notes & caveats to doing this (using UDTs with the far memory arrays class). First, when using these StringFromUdtViaPtr & UdtFromStringViaPtr procedures, be sure you specify that bAppendNonZero is True (for both calls). This is necessary because it's easy for UDTs to end with a zero (vbNullChar), and this isn't allowed for the vbString arrays in the ArraysInFarMemory class. Setting bAppendNonZero solves this problem. However, another point is brought up. When specifying iFixedStringCharLen in the Initialize call of the ArraysInFarMemory class, you must make sure it's at least as large as the following calculation:
This assures that the strings in far memory are large enough to hold your UDTs, including the extra character for making sure they don't end in vbNullChar. However, since iFixedStringCharLen must also be a power of 2, this probably won't often be a problem. That calculation just shows the minimum that iFixedStringCharLen must be for any specific UDT.
Here's a function for calculating the size that iFixedStringCharLen must be for any specific UDT. Just plug a declared UDT of your Type into it, and you can use the return to specify iFixedStringCharLen in the ArraysInFarMemory class's Initialize procedure.
Code:
Public Function FixedStringCharLenForUdt(LenBofUdt As Long) As Long
Dim i As Long, j As Long
i = (LenBofUdt + 1&) \ 2& + 1&
j = 1&
Do
If j >= i Then Exit Do
j = j * 2&
Loop
FixedStringCharLenForUdt = j
End Function
--------------------------------------
Also, as should be obvious to people who are familiar with the workings of UDTs, it's probably a bad idea to use this with UDTs that contain pointers (i.e., UDTs with BSTR strings, objects, or dynamic arrays). Copying these types of UDTs must be done with great care, and none of that is considered herein.
Last edited by Elroy; Jul 4th, 2022 at 07:50 PM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
can you provide an example please.
in the main program it works perfectly to read and write udt.
but in another program it gives problems with erroneous data or the program closes.
Main Program
Code:
Option Explicit
Private Const UniqueName As String = "testvb6memori"
'
Private Type TestUdtType
s1 As String
s2 As String
i1 As Long
d1 As Double
fecha As Date
End Type
Private u As TestUdtType
Private oStr2 As ArraysInFarMemory
Private Sub Command3_Click()
Dim u2 As TestUdtType
Call UdtFromStringViaPtr(VarPtr(u2), LenB(u2), oStr2(1&), True)
MsgBox u2.s1 & vbNewLine & u2.s2 & vbNewLine & u2.i1 & vbNewLine & u2.d1 & vbNewLine & u2.fecha
End Sub
Private Sub Command4_Click()
u.s1 = "cambiado"
u.s2 = "datos"
u.i1 = 699999
u.d1 = 6.999
u.fecha = Now
oStr2(1&) = StringFromUdtViaPtr(VarPtr(u), LenB(u), True)
End Sub
Private Sub Form_Load()
Dim existe As Boolean
Set oStr2 = New ArraysInFarMemory
existe = FarMemoryFileExists(UniqueName)
oStr2.Initialize UniqueName, vbString, 700000, 256&, existe
oStr2(0&) = "dato inicial"
u.s1 = "asdf"
u.s2 = "qwer"
u.i1 = 1234
u.d1 = 5.678
u.fecha = Now
oStr2(1&) = StringFromUdtViaPtr(VarPtr(u), LenB(u), True)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set oStr2 = Nothing
End Sub
Other:
Code:
Option Explicit
Private Const UniqueName As String = "testvb6memori"
'
Private oStr2 As ArraysInFarMemory
Private Type TestUdtType
s1 As String
s2 As String
i1 As Long
d1 As Double
fecha As Date
End Type
Private u As TestUdtType
Private Sub Command3_Click()
Dim u2 As TestUdtType
Call UdtFromStringViaPtr(VarPtr(u2), LenB(u2), oStr2(1&), True)
MsgBox u2.s1 & vbNewLine & u2.s2 & vbNewLine & u2.i1 & vbNewLine & u2.d1 & vbNewLine & u2.fecha
End Sub
Private Sub Command4_Click()
u.s1 = "cambiar"
u.s2 = "datos"
u.i1 = 12345
u.d1 = 6.967676
u.fecha = Now
oStr2(1&) = StringFromUdtViaPtr(VarPtr(u), LenB(u), True)
End Sub
Private Sub Form_Load()
Dim existe As Boolean
Set oStr2 = New ArraysInFarMemory
existe = FarMemoryFileExists(UniqueName)
oStr2.Initialize UniqueName, vbString, 700000, 256&, existe
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set oStr2 = Nothing
End Sub
Ok, I created an example using the vbString option of the class, as it seemed like that's what you were interested in (although I have confidence it'll work with any variable type).
Two projects are attached in the ZIP file, but let me go through what's going on.
The first project (TestPart1) just opens a far memory vbString array named "StrTest", and writes a bit of data into it. We must execute this TestPart1 before we do anything with TestPart2, and we must leave TestPart1 executing. Doing it all in the IDE is fine.
Here's the code in frmTestPart1.frm:
Code:
Option Explicit
'
Dim oStr As ArraysInFarMemory
Private Sub Form_Load()
Set oStr = New ArraysInFarMemory
oStr.Initialize "StrTest", vbString, 500&, 256&
'
oStr(0&) = "aaaa"
oStr(1&) = "bbbbbbbbbbbb"
oStr(2&) = "ccccccccccccccccccccc"
oStr(499&) = "dddddddd"
' We just leave it open so another program can read it.
' When we close the form, it'll uninstantiate oStr.
End Sub
Once it's running, our far memory array is active. To see how we fetch it from another process (i.e., program), we will now execute TestPart2 (just using another loaded copy of the IDE).
Here's the code in frmTestPart2.frm:
Code:
Option Explicit
'
Dim oStr As ArraysInFarMemory
Private Sub Form_Load()
Set oStr = New ArraysInFarMemory
oStr.Initialize "StrTest", vbString, 500&, 256&, True
'
Debug.Print "'"; oStr(0&); "'" ' Should be 'aaaa' and it IS!
Debug.Print "'"; oStr(1&); "'" ' Should be 'bbbbbbbbbbbb' and it IS!
Debug.Print "'"; oStr(2&); "'" ' Should be 'ccccccccccccccccccccc' and it IS!
Debug.Print "'"; oStr(499&); "'" ' Should be 'dddddddd' and it IS!
' We can close here, if we like, as it should still be open from test #1.
End Sub
So, it seems to be working for me. A couple of things to point out:
1) In TestPart2, the optional bOpenOnlyNoCreate argument of the class's Initialize event was specified. That's because TestPart2 is just opening the far memory array, it's not creating it, as that was done by TestPart1.
2) Both VBP files are using the same ArraysInFarMemory.cls.
3) We must be sure that both processes are using the same far memory file name (in this case "StrTest").
--------------
So, it seems to be working on my computer.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
nooo.
passing string from one program to another works perfectly.
my problem is with the udt.
Sorry if I explain myself wrong.
a greeting
Ok, I was putting together an example and I saw your problem. You've got BSTR type variable length strings in your UDT. That's an awful idea (as discussed in the OP), as they're only in there via pointer. I didn't study your code but that could be exactly why you're seeing funny data.
I'll go ahead and put together an example though, to be posted in a few minutes.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Yep, it all seems to be working fine with UDTs. I included a BAS module with the following code (from posts #5 & #8 above) in both test projects, although I didn't use the FarMemoryFileExists procedure:
Code:
Option Explicit
'
Private Declare Function CreateFileMapping Lib "kernel32" Alias "CreateFileMappingA" (ByVal hFile As Long, ByVal lpFileMappigAttributes As Long, ByVal flProtect As Long, ByVal dwMaximumSizeHigh As Long, ByVal dwMaximumSizeLow As Long, ByVal lpName As String) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
'
Public Function StringFromUdtViaPtr(PtrToUdt As Long, LenBofUdt As Long, Optional bAppendNonZero As Boolean) As String
StringFromUdtViaPtr = String$((LenBofUdt + 1&) \ 2& + Abs(bAppendNonZero), vbNullChar)
If bAppendNonZero Then Mid$(StringFromUdtViaPtr, Len(StringFromUdtViaPtr), 1&) = vbLf ' Append ChrW$(&h10) to make sure it's not terminated in a vbNullChar.
CopyMemory ByVal StrPtr(StringFromUdtViaPtr), ByVal PtrToUdt, LenBofUdt ' On odd length UDTs, it won't completely fill the last Unicode character, but that's fine.
End Function
Public Sub UdtFromStringViaPtr(PtrToUdt As Long, LenBofUdt As Long, s As String, Optional bAppendNonZero As Boolean)
If Len(s) <> (LenBofUdt + 1&) \ 2& + Abs(bAppendNonZero) Then Err.Raise 13&, , "String isn't correct length for this UDT"
CopyMemory ByVal PtrToUdt, ByVal StrPtr(s), LenBofUdt
End Sub
Public Function FarMemoryFileExists(ByRef sUniqueName As String) As Boolean
'
' Just temporarily open our far memory file with one byte.
Dim hMemFile As Long
Const INVALID_HANDLE_VALUE As Long = -1&
Const PAGE_READWRITE As Long = 4&
hMemFile = CreateFileMapping(INVALID_HANDLE_VALUE, 0&, PAGE_READWRITE, 0&, 1&, sUniqueName)
'
' Save any error.
Dim iLastDllError As Long
iLastDllError = Err.LastDllError
'
' Close (clean up).
If hMemFile Then
If CloseHandle(hMemFile) = 0& Then Err.Raise Err.LastDllError, "FarMemoryFileExists", "CreateFileMapping API system error."
End If
'
' See if we got an unusual error.
If hMemFile = 0& Then
If iLastDllError = 1450& Then
Err.Raise iLastDllError, "FarMemoryFileExists", "CreateFileMapping error ERROR_NO_SYSTEM_RESOURCES. This probably means you don't have enough memory in this computer to map file(s) as large as you're trying to, or maybe memory is full with other executing programs."
Else
Err.Raise iLastDllError, "FarMemoryFileExists", "CreateFileMapping API system error."
End If
End If
'
' See if we got an already exists error, and put into return.
Const ERROR_ALREADY_EXISTS As Long = 183&
FarMemoryFileExists = iLastDllError = ERROR_ALREADY_EXISTS
End Function
Used the class from the OP, and both test projects.
And here's the code I put into the form of Test part #1 project. Notice the fixed-length strings in the UDT declaration:
Code:
Option Explicit
'
Dim oStr As ArraysInFarMemory
'
Private Type TestUdtType
s1 As String * 8
s2 As String * 8
i1 As Long
d1 As Double
fecha As Date
End Type
'
Private Sub Form_Load()
Set oStr = New ArraysInFarMemory
Dim u As TestUdtType
oStr.Initialize "StrTest", vbString, 500&, 256&
'
u.s1 = "s0000": u.i1 = 0&: u.fecha = #10/10/2000#: oStr(0&) = StringFromUdtViaPtr(VarPtr(u), LenB(u), True)
u.s1 = "s0001": u.i1 = 1&: u.fecha = #11/11/2111#: oStr(1&) = StringFromUdtViaPtr(VarPtr(u), LenB(u), True)
u.s1 = "s0400": u.i1 = 400&: u.fecha = #1/1/2400#: oStr(400&) = StringFromUdtViaPtr(VarPtr(u), LenB(u), True)
' We just leave it open so another program can read it.
' When we close the form, it'll uninstantiate oStr.
End Sub
And here's the code I put in the form of test part #2 project:
Code:
Option Explicit
'
Dim oStr As ArraysInFarMemory
'
Private Type TestUdtType
s1 As String * 8
s2 As String * 8
i1 As Long
d1 As Double
fecha As Date
End Type
'
Private Sub Form_Load()
Set oStr = New ArraysInFarMemory
oStr.Initialize "StrTest", vbString, 500&, 256&, True
'
Dim u As TestUdtType
Call UdtFromStringViaPtr(VarPtr(u), LenB(u), oStr(0&), True): Debug.Print u.s1, u.i1, u.fecha ' Should be "s0000", 0, 10/10/2000
Call UdtFromStringViaPtr(VarPtr(u), LenB(u), oStr(1&), True): Debug.Print u.s1, u.i1, u.fecha ' Should be "s0001", 1, 11/11/2111
Call UdtFromStringViaPtr(VarPtr(u), LenB(u), oStr(400&), True): Debug.Print u.s1, u.i1, u.fecha ' Should be "s4000", 400, 1/1/2400
' We can close here, if we like, as it should still be open from test #1.
End Sub
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Because a BSTR type string is nothing but a pointer in the UDT. And, when you send it through something like StringFromUdtViaPtr, all your getting is a copy of the string pointer, and not the actual string. Furthermore, when you fetch that pointer there's no guarantee that the string will still be at that memory location, not to mention the memory allocation/deallocation that goes along with BSTR strings.
And, if you fetch that string pointer from another program, that memory pointer will absolutely not point toward the original string, as you'll be in a completely different 32-bit address space.
This really has nothing to do with the far memory array, nor the idea of putting UDTs into strings. It's all about the data versus pointer being in the UDT. For BSTR strings, dynamic arrays, and/or objects in UDTs, all you have is a pointer. And you really shouldn't be copying those pointers, as all kinds of things can get fouled up if you do.
Last edited by Elroy; Jul 6th, 2022 at 03:24 PM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Option Explicit
'
Private Type TestUdtType
s1 As String * 8
s2 As String * 8
i1 As Long
d1 As Double
fecha As Date
End Type
Private Sub Form_Load()
Dim u1 As TestUdtType
Dim u2 As TestUdtType
u1.s1 = "asdf"
u1.fecha = #1/1/2022#
u2 = u1 ' Here, we're truly just COPYING the UDT, which we could just as easily have done with the CopyMemory API.
End Sub
And then, see comments in this example:
Code:
Option Explicit
'
Private Type TestUdtType
s1 As String * 8
s2 As String * 8
i1 As Long
d1 As Double
fecha As Date
s3 As String ' BSTR string.
o As Collection
a() As Long
End Type
Private Sub Form_Load()
Dim u1 As TestUdtType
Dim u2 As TestUdtType
u1.s3 = "BSTR string" ' This is actually allocating memory and creating a BSTR string.
u1.fecha = #1/1/2022#
Set u1.o = New Collection ' \ These two instantiate a collection object
u1.o.Add "item", "key" ' / and put an item into it.
'
ReDim u1.a(1 To 10) ' \ These two allocate a SafeArray header, allocate the array memory
u1.a(5) = 1234 ' / and then assign a non-zero value to the 5th item.
u2 = u1 ' This is doing MUCH more than people typically realize.
' Because the UDT has a BSTR string (s3), an object, and a dynamic array,
' It's doing a LOT of work:
' 1) It's creating a second BSTR string, allocating memory for it, and then copying the original.
' 2) It's creating a second reference to our Collection object (although not creating an entirely new object).
' 3) It's creating a second dynamic array (including SafeArray header and array space), and copying entire original array.
' And all three of the above are just pointers in the UDT.
End Sub
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
No problem. Let me/us know if you use this thing and how it performs.
I'm hoping Eduardo will jump back in and do some performance testing of this thing. It certainly won't perform as fast as accessing typical arrays within our 32-bit address space, but it should be much faster than anything disk-based (so long as Windows paging doesn't kick in).
OK, I'm back to this issue.
I made my own implementation (I copied some thing from yours ), trying to achieve as good performance as possible.
Unfortunately, I'm disappointed because it is slooooooow compared to VB6 arrays.
I've set up a test program, comparing VB6 arrays, yours and mine.
VB6 is in the order of 2000 times faster.
About our classes, it depends, for random access your is faster, for sequential or repeated access mine is slightly faster.
I'm not really satisfied, but perhaps I'll have to accept it.
Until I could work in tB in win64 and with unsigned LongLong, this is what seems to be just available for now.
I guess it could be improved somehow, there are many conversions to CDec that must be sucking time. But I'm a bit tired already, and I don't have much hopes to improve it very much.
I also made a variable length String array.
That one for sequential access seems to perform better, in the order of 20x regarding VB6.
I could post it later, or in another thread (whatever is more appropriate).
For a fair comparison though, we'd need to compare it all with some disk I/O version, because we can do things with far memory that we can't do with our 32-bit address space. And even at that, it should really be a disk I/O with API calls that breaks the 4GB boundary, because that's really what we're talking about.
Also, I suspect mine is faster under certain circumstances because I'm buffering the MapViewOfFile window, not re-creating it on every call. However, you'd think that'd help in the sequential access more than the random access.
But yeah, it doesn't surprise me that it's substantially slower than just using our 32-bit address space.
And, when you get to a place where you like it, I'd love to see your version.
Best,
Elroy
Last edited by Elroy; Jul 13th, 2022 at 09:20 AM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Excuse the stupid question ... on what occasions can the use of this class be useful? ie what programming problems does it solve?
I don't really understand.
Yes, Arnoutdv outlined it perfectly. This approach opens up the entire 64-bit memory address space to data storage and manipulation, using only VB6.
Furthermore, it actually gets it out of our VB6 32-bit address space (in the event we're running close).
Also (almost as a side-effect), it provides a fairly easy way for inter-process data sharing in memory.
---------------
Bottom line though, if you're not writing a high-memory-usage application and/or have no need for inter-process data sharing, there's no need for you to consider any of this.
Last edited by Elroy; Jul 14th, 2022 at 09:14 AM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.