I have written a VB-Class to provide a data table, which is allowing you to handle data in a two-dimensional array (of type variant) similar to a ADO recordset.
To improve processing speed when adding records to the array, sorting the array (i.e. moving records around in the array) or reading records from the array, I want to use the RtlMoveMemory routine of the kernel32.dll of the Windows API. Whilst I have been able to successfully move around records within the array, writing data to a specific index of the array or reading data from a specific index of the array seems to somehow mix up the data upon further processing.
I have done quite a bit of reading to get where I am including the following:
1.
http://www.codeguru.com/vb/gen/vb_mi...tores-Data.htm
2.
https://stackoverflow.com/questions/...ference-in-vba
3.
https://stackoverflow.com/questions/...43721#24843721
As you will see, my code is an adaption of link no. 3 above. I am not a real pro but I am not an absolute beginner neither and I must be missing something but I can't figure out what.
Here is the code as it stands today:
Code:
Option Explicit
Option Base 1
'#======================================================================================================================
'# References
'#======================================================================================================================
#If Win64 Then
Private Const PTR_LENGTH As Long = 8
Private Declare PtrSafe Function VarPtrArray Lib "VBE7" Alias "VarPtr" (ByRef Var() As Any) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#Else
Private Const PTR_LENGTH As Long = 4
Private Declare Function VarPtrArray Lib "VBE7" Alias "VarPtr" (ByRef Var() As Any) As LongPtr
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If
'#======================================================================================================================
'# API Constants, Enumerations & Types
'#======================================================================================================================
'Type Declarations needed for SafeArray hacks
'The bounds of the SafeArray
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY1D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 0) As SAFEARRAYBOUND
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
'#======================================================================================================================
'# Private Variables
'#======================================================================================================================
Private m_List() As Variant ' The list array.
'#======================================================================================================================
'# Test Routines
'#======================================================================================================================
Private Sub MainTest()
Dim iIdx As Long
Dim aSingleRec() As Variant
Dim i As Long
LoadRange ActiveSheet.Range("dataInput")
DataRowMove 5, 2
DebugRecord 5
DebugRecord 2
ReDim aSingleRec(LBound(m_List, 1) To UBound(m_List, 1))
aSingleRec(1) = "Test Gender (m)"
aSingleRec(2) = "Steve"
aSingleRec(3) = "Rogers"
aSingleRec(4) = "425 Lafayette St"
aSingleRec(5) = 10003
aSingleRec(6) = "New York"
DataRowPush 4, aSingleRec
DebugRecord 4
DebugSingleRecord aSingleRec
aSingleRec(1) = "Test Gener (f)"
aSingleRec(2) = "Wanda"
aSingleRec(3) = "Maximoff"
aSingleRec(4) = "72 W 36th St"
aSingleRec(5) = 10018
aSingleRec(6) = "New York"
DataRowPush 6, aSingleRec
DebugRecord 6
DebugSingleRecord aSingleRec
aSingleRec = DataRowGet(7)
DebugSingleRecord aSingleRec
DumpToRange ActiveSheet, ActiveSheet.Cells(10, 2)
Debug.Print "Done..."
End Sub
Private Sub LoadRange(rInput As Range)
m_List = rInput
End Sub
Private Sub DumpToRange(TargetWorksheet As Worksheet, TargetCell As Range)
Dim iRow As Integer: iRow = TargetCell.Row
Dim iCol As Integer: iCol = TargetCell.Column
TargetWorksheet.Cells(iRow, iCol).Resize(UBound(m_List), UBound(m_List, 2)) = m_List
End Sub
Private Sub DebugRecord(iIdx As Long, Optional stInProcedure = "Main")
Dim i As Long
Debug.Print "---------------------------"
Debug.Print "Record " & iIdx & " (in Procedure '" & stInProcedure & "')" & vbCrLf
For i = 1 To UBound(m_List, 1)
Debug.Print vbTab & "Field " & i & "[" & TypeName(m_List(i, iIdx)) & "] -> " & m_List(i, iIdx)
Next i
Debug.Print vbCrLf
End Sub
Private Sub DebugSingleRecord(aRec() As Variant)
Dim i As Long
Debug.Print "---------------------------"
Debug.Print "Single Record " & vbCrLf
For i = 1 To UBound(aRec)
Debug.Print vbTab & "Field " & i & "[" & TypeName(aRec(i)) & "] -> " & aRec(i)
Next i
Debug.Print vbCrLf
End Sub
'#======================================================================================================================
'# Data Handling Routines
'#======================================================================================================================
Private Function DataRowGet(ByVal idxFrom As Long) As Variant()
Dim ptrToArrayVar As LongPtr
Dim ptrToSafeArray As LongPtr
Dim ptrToArrayData As LongPtr
Dim ptrToArrayData2 As LongPtr
Dim uSAFEARRAY As SAFEARRAY1D
Dim ptrCursor As LongPtr
Dim cbElements As Long
Dim atsBound1 As Long
Dim elSize As Long
Dim aSingleRec() As Variant
Dim m_NumCols As Long
m_NumCols = UBound(m_List, 1)
ReDim aSingleRec(LBound(m_List, 1) To UBound(m_List, 1))
'determine bound1 of source array (ie row Count)
atsBound1 = m_NumCols
'get pointer to source array Safearray
ptrToArrayVar = VarPtrArray(m_List)
CopyMemory ptrToSafeArray, ByVal ptrToArrayVar, PTR_LENGTH
'get the safearray structure
CopyMemory uSAFEARRAY, ByVal ptrToSafeArray, LenB(uSAFEARRAY)
'get the pointer to the data elemets
ptrToArrayData = uSAFEARRAY.pvData
'determine byte size of source elements
cbElements = uSAFEARRAY.cbElements
'get pointer to destination array Safearray
ptrToArrayVar = VarPtrArray(aSingleRec)
CopyMemory ptrToSafeArray, ByVal ptrToArrayVar, PTR_LENGTH
CopyMemory uSAFEARRAY, ByVal ptrToSafeArray, LenB(uSAFEARRAY)
ptrToArrayData2 = uSAFEARRAY.pvData
'determine elements size
elSize = m_NumCols
'determine start position of data in source array
ptrCursor = ptrToArrayData + (((idxFrom - 1) * atsBound1) * cbElements)
'Copy source array to destination array
CopyMemory ByVal ptrToArrayData2, ByVal ptrCursor, cbElements * elSize
DataRowGet = aSingleRec
ReDim aSingleRec(0 To 0)
End Function
Private Sub DataRowPush(ByVal idxTo As Long, ByRef sourceArray() As Variant)
Dim ptrToArrayVar As LongPtr
Dim ptrToSafeArray As LongPtr
Dim ptrToArrayData As LongPtr
Dim ptrToArrayData2 As LongPtr
Dim uSAFEARRAY As SAFEARRAY1D
Dim ptrCursor As LongPtr
Dim ptrCursorSource As LongPtr
Dim cbElementsS As Long
Dim cbElementsT As Long
Dim atsBound1 As Long
Dim elSize As Long
Dim m_NumCols As Long
Dim aSingleRec() As Variant
aSingleRec = sourceArray
m_NumCols = UBound(m_List, 1)
'determine bound1 of source array (ie row Count)
atsBound1 = m_NumCols
'get pointer to target array Safearray
ptrToArrayVar = VarPtrArray(m_List)
CopyMemory ptrToSafeArray, ByVal ptrToArrayVar, PTR_LENGTH
'get the safearray structure
CopyMemory uSAFEARRAY, ByVal ptrToSafeArray, LenB(uSAFEARRAY)
'get the pointer to the data elemets
ptrToArrayData = uSAFEARRAY.pvData
'determine byte size of source elements
cbElementsT = uSAFEARRAY.cbElements
'get pointer to source array Safearray
ptrToArrayVar = VarPtrArray(aSingleRec)
CopyMemory ptrToSafeArray, ByVal ptrToArrayVar, PTR_LENGTH
'get the safearray structure
CopyMemory uSAFEARRAY, ByVal ptrToSafeArray, LenB(uSAFEARRAY)
'get the pointer to the data elemets
ptrToArrayData2 = uSAFEARRAY.pvData
'determine byte size of source elements
cbElementsS = uSAFEARRAY.cbElements
'determine elements size
elSize = m_NumCols
'determine start position of data in target array
ptrCursor = ptrToArrayData + (((idxTo - 1) * atsBound1) * cbElementsT)
'Copy source array to destination array
CopyMemory ByVal ptrCursor, ByVal ptrToArrayData2, cbElementsS * elSize
'Debugging only
DebugRecord idxTo, "DataRowPush"
End Sub
Private Sub DataRowMove(ByVal idxFrom As Long, ByVal idxTo As Long)
Dim ptrToArrayVar As LongPtr
Dim ptrToSafeArray As LongPtr
Dim ptrToArrayData As LongPtr
Dim ptrToArrayData2 As LongPtr
Dim uSAFEARRAY As SAFEARRAY1D
Dim ptrCursorFrom As LongPtr
Dim ptrCursorTo As LongPtr
Dim cbElements As Long
Dim atsBound1 As Long
Dim elSize As Long
Dim m_NumCols As Long
m_NumCols = UBound(m_List, 1)
'determine bound1 of source array (ie row Count)
atsBound1 = m_NumCols
'get pointer to source array Safearray
ptrToArrayVar = VarPtrArray(m_List)
CopyMemory ptrToSafeArray, ByVal ptrToArrayVar, PTR_LENGTH
'get the safearray structure
CopyMemory uSAFEARRAY, ByVal ptrToSafeArray, LenB(uSAFEARRAY)
'get the pointer to the data elemets
ptrToArrayData = uSAFEARRAY.pvData
'determine byte size of source elements
cbElements = uSAFEARRAY.cbElements
'determine elements size
elSize = m_NumCols
'determine start position of data source in array
ptrCursorFrom = ptrToArrayData + (((idxFrom - 1) * atsBound1) * cbElements)
'determine start position of data target in array
ptrCursorTo = ptrToArrayData + (((idxTo - 1) * atsBound1) * cbElements)
'Copy source array to destination array
CopyMemory ByVal ptrCursorTo, ByVal ptrCursorFrom, cbElements * elSize
End Sub
This results in the following output:
Code:
---------------------------
Record 5 (in Procedure 'Main')
Field 1[String] -> Mr
Field 2[String] -> Peter
Field 3[String] -> Parker
Field 4[String] -> 401 7th Ave
Field 5[Double] -> 10001
Field 6[String] -> New York
---------------------------
Record 2 (in Procedure 'Main')
Field 1[String] -> Mr
Field 2[String] -> Peter
Field 3[String] -> Parker
Field 4[String] -> 401 7th Ave
Field 5[Double] -> 10001
Field 6[String] -> New York
---------------------------
Record 4 (in Procedure 'DataRowPush')
Field 1[String] -> Test Gender (m)
Field 2[String] -> Steve
Field 3[String] -> Rogers
Field 4[String] -> 425 Lafayette St
Field 5[Integer] -> 10003
Field 6[String] -> New York
---------------------------
Record 4 (in Procedure 'Main')
Field 1[String] -> Test Gender (m)
Field 2[String] -> Steve
Field 3[String] -> Field
Field 4[String] -> Field 4[String
Field 5[Integer] -> 10003
Field 6[String] -> New York
---------------------------
Single Record
Field 1[String] -> Test Gender (m)
Field 2[String] -> Steve
Field 3[String] -> Rogers
Field 4[String] -> 425 Lafayette St
Field 5[Integer] -> 10003
Field 6[String] -> New York
---------------------------
Record 6 (in Procedure 'DataRowPush')
Field 1[String] -> Test Gener (f)
Field 2[String] -> Wanda
Field 3[String] -> Maximoff
Field 4[String] -> 72 W 36th St
Field 5[Integer] -> 10018
Field 6[String] -> New York
---------------------------
Record 6 (in Procedure 'Main')
Field 1[String] -> Test Gener (f)
Field 2[String] -> Field
Field 3[String] -> Maximoff
Field 4[String] -> 72 W 36th St
Field 5[Integer] -> 10018
Field 6[String] -> New York
---------------------------
Single Record
Field 1[String] -> Test Gener (f)
Field 2[String] -> Wanda
Field 3[String] -> Maximoff
Field 4[String] -> 72 W 36th St
Field 5[Integer] -> 10018
Field 6[String] -> New York
---------------------------
Single Record
Field 1[String] -> Mr
Field 2[String] -> Bruce
Field 3[String] -> Banner
Field 4[String] -> 222 W 51st St
Field 5[Double] -> 10019
Field 6[String] -> New York
Done...
My main issue is with 'DataRowPush' which seems to work fine while within the procedure itself but as soon as the program returns to the calling procedure, the content of the target array seems to be altered. You can see this in the debug output of records 4 and 6 above.
Similarly when reading the data with 'DataRowGet', the target single dimensional array is correctly populated but it seems the original data in m_List (the 2-dimensional array) seems to be altered as well. After reading the data with 'DataRowGet' Record no. 7 reads as
Code:
Mr
Resize
6
Field 6
10019
Field 6[
in m_List. Appreciate any help how to change my code to prevent the altering of the data.
