VBA Array Functions: insert Element, remove Element The Next CEO of Stack OverflowPorting ProcMonDebugOutput from C# to VBAWin32 File API in VBAFunctional FrameworkMapping one array onto another where columns from first array become rows in second arrayVBA UDF SUMIF with Array ParametersVBA Script to Remove DuplicatesPerformance of generic VS non-generic method (array generating function)Speed up array loop vba ExcelVba to create a new column and insert array formulaVBA array functions: push, pop, shift, unshift
What is the value of α and β in a triangle?
Can MTA send mail via a relay without being told so?
How many extra stops do monopods offer for tele photographs?
Powershell. How to parse gci Name?
Rotate a column
Is it okay to majorly distort historical facts while writing a fiction story?
Where do students learn to solve polynomial equations these days?
Chain wire methods together in Lightning Web Components
How do I align (1) and (2)?
Example of a Mathematician/Physicist whose Other Publications during their PhD eclipsed their PhD Thesis
Is it convenient to ask the journal's editor for two additional days to complete a review?
I want to delete every two lines after 3rd lines in file contain very large number of lines :
What happened in Rome, when the western empire "fell"?
"misplaced omit" error when >centering columns
Which one is the true statement?
Bartok - Syncopation (1): Meaning of notes in between Grand Staff
I believe this to be a fraud - hired, then asked to cash check and send cash as Bitcoin
If Nick Fury and Coulson already knew about aliens (Kree and Skrull) why did they wait until Thor's appearance to start making weapons?
Is there a difference between "Fahrstuhl" and "Aufzug"
Make solar eclipses exceedingly rare, but still have new moons
Why does the flight controls check come before arming the autobrake on the A320?
When you upcast Blindness/Deafness, do all targets suffer the same effect?
Flying from Cape Town to England and return to another province
Running a General Election and the European Elections together
VBA Array Functions: insert Element, remove Element
The Next CEO of Stack OverflowPorting ProcMonDebugOutput from C# to VBAWin32 File API in VBAFunctional FrameworkMapping one array onto another where columns from first array become rows in second arrayVBA UDF SUMIF with Array ParametersVBA Script to Remove DuplicatesPerformance of generic VS non-generic method (array generating function)Speed up array loop vba ExcelVba to create a new column and insert array formulaVBA array functions: push, pop, shift, unshift
2
$begingroup$
An extension to array functions I am building for my snake game. This one allows you to remove / insert particular elements.
API CALLS
Private Declare PtrSafe Function VarPtrArray Lib "VBE7" Alias "VarPtr" _
(ByRef Var() As Any) As LongPtr
Private Declare PtrSafe Sub CopyMemoryI Lib "kernel32.dll" Alias "RtlMoveMemory" _
(ByVal dst As LongPtr, ByVal src As LongPtr, ByVal Length As Long)
Private Declare PtrSafe Sub CopyMemoryII Lib "kernel32.dll" Alias "RtlMoveMemory" _
(ByRef dst As SAFEARRAY, ByVal src As LongPtr, ByVal Length As Long)
DATA STRUCTS
Private Type SAFEARRAY_BOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As LongPtr
rgsabound(0) As SAFEARRAY_BOUND
End Type
Private Type SnakePart
Column As Long
Row As Long
End Type
Private Const SNAKEPART_BYTELENGTH = 8
FUNCTIONS
Private Function ArrayInsertElement(ByRef ArrayOriginal() As SnakePart, ByRef ElementToAdd As SnakePart, ByRef Position As Long) As SnakePart()
Dim NewLength As Long
Dim CopiedBytesFirstSection As Long
Dim CopiedBytesSecondSection As Long
NewLength = UBound(ArrayOriginal) + 1
ReDim ArrayInsertElement(NewLength)
CopiedBytesFirstSection = Position * SNAKEPART_BYTELENGTH
CopiedBytesSecondSection = (NewLength - Position) * SNAKEPART_BYTELENGTH
CopyMemoryI ArrayElementGetPointer(ArrayInsertElement, 0, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, 0, SNAKEPART_BYTELENGTH), CopiedBytesFirstSection
CopyMemoryI ArrayElementGetPointer(ArrayInsertElement, Position, SNAKEPART_BYTELENGTH), VarPtr(ElementToAdd), SNAKEPART_BYTELENGTH
CopyMemoryI ArrayElementGetPointer(ArrayInsertElement, Position + 1, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, Position, SNAKEPART_BYTELENGTH), CopiedBytesSecondSection
End Function
Private Function ArrayRemoveElement(ByRef ArrayOriginal() As SnakePart, ByRef Position As Long) As SnakePart()
Dim NewLength As Long
Dim CopiedBytesFirstSection As Long
Dim CopiedBytesSecondSection As Long
NewLength = UBound(ArrayOriginal) - 1
ReDim ArrayRemoveElement(NewLength)
CopiedBytesFirstSection = Position * SNAKEPART_BYTELENGTH
CopiedBytesSecondSection = (UBound(ArrayOriginal) - Position) * SNAKEPART_BYTELENGTH
CopyMemoryI ArrayElementGetPointer(ArrayRemoveElement, 0, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, 0, SNAKEPART_BYTELENGTH), CopiedBytesFirstSection
CopyMemoryI ArrayElementGetPointer(ArrayRemoveElement, Position, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, Position + 1, SNAKEPART_BYTELENGTH), CopiedBytesSecondSection
End Function
Private Function ArrayElementGetPointer(ByRef Arr() As SnakePart, ByVal ElementIndex As Long, ByVal ElementByteLength As Long) As LongPtr
Dim ptrToArrayVar As LongPtr
Dim ptrToSafeArray As LongPtr
Dim ptrToArrayData As LongPtr
Dim ptrCursor As LongPtr
Dim uSAFEARRAY As SAFEARRAY
' Get Pointer To Array *Variable*
ptrToArrayVar = VarPtrArray(Arr)
' Get Pointer To Array Variable *SAFEARRAY* By Directly Reading Array Variable
CopyMemoryI VarPtr(ptrToSafeArray), ptrToArrayVar, 8
' Read The SAFEARRAY Structure
CopyMemoryII uSAFEARRAY, ptrToSafeArray, LenB(uSAFEARRAY)
' Get Pointer To Array Data
ptrToArrayData = uSAFEARRAY.pvData
' Get Pointer To Array Element
ptrCursor = ptrToArrayData + (ElementIndex * ElementByteLength)
ArrayElementGetPointer = ptrCursor
End Function
TESTS
Private Sub ArrayInsertElementTest()
Dim x(3) As SnakePart
Dim sp As SnakePart
sp.Column = 1
sp.Row = 1
x(0) = sp
x(1) = sp
x(2) = sp
x(3) = sp
Debug.Print x(0).Column = 1
Debug.Print x(1).Column = 1
Debug.Print x(2).Column = 1
Debug.Print x(3).Column = 1
Debug.Print "_______________________"
Dim temparry() As SnakePart
temparry = x
sp.Column = 2
sp.Row = 2
temparry = ArrayInsertElement(temparry, sp, 2)
Debug.Print temparry(0).Column = 1
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 2
Debug.Print temparry(3).Column = 1
Debug.Print temparry(4).Column = 1
Debug.Print "_______________________"
sp.Column = 4
sp.Row = 4
temparry = ArrayInsertElement(temparry, sp, 4)
Debug.Print temparry(0).Column = 1
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 2
Debug.Print temparry(3).Column = 1
Debug.Print temparry(4).Column = 4
Debug.Print temparry(5).Column = 1
Debug.Print "_______________________"
sp.Column = 0
sp.Row = 0
temparry = ArrayInsertElement(temparry, sp, 0)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 1
Debug.Print temparry(3).Column = 2
Debug.Print temparry(4).Column = 1
Debug.Print temparry(5).Column = 4
Debug.Print temparry(6).Column = 1
Debug.Print "_______________________"
End Sub
Private Sub ArrayRemoveElementTest()
Dim x(5) As SnakePart
Dim sp As SnakePart
sp.Column = 0
sp.Row = 0
x(0) = sp
sp.Column = 1
sp.Row = 1
x(1) = sp
sp.Column = 2
sp.Row = 2
x(2) = sp
sp.Column = 3
sp.Row = 3
x(3) = sp
sp.Column = 4
sp.Row = 4
x(4) = sp
sp.Column = 5
sp.Row = 5
x(5) = sp
Debug.Print x(0).Column = 0
Debug.Print x(1).Column = 1
Debug.Print x(2).Column = 2
Debug.Print x(3).Column = 3
Debug.Print x(4).Column = 4
Debug.Print x(5).Column = 5
Debug.Print "_______________________"
Dim temparry() As SnakePart
temparry = x
temparry = ArrayRemoveElement(temparry, 4)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 2
Debug.Print temparry(3).Column = 3
Debug.Print temparry(4).Column = 5
Debug.Print "_______________________"
temparry = ArrayRemoveElement(temparry, 2)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 3
Debug.Print temparry(3).Column = 5
Debug.Print "_______________________"
temparry = ArrayRemoveElement(temparry, 1)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 3
Debug.Print temparry(2).Column = 5
Debug.Print "_______________________"
temparry = ArrayRemoveElement(temparry, 0)
Debug.Print temparry(0).Column = 3
Debug.Print temparry(1).Column = 5
Debug.Print "_______________________"
End Sub
performance vba excel winapi
asked 2 days ago
learnAsWeGolearnAsWeGo
2987
$endgroup$
add a comment |
2
$begingroup$
An extension to array functions I am building for my snake game. This one allows you to remove / insert particular elements.
API CALLS
Private Declare PtrSafe Function VarPtrArray Lib "VBE7" Alias "VarPtr" _
(ByRef Var() As Any) As LongPtr
Private Declare PtrSafe Sub CopyMemoryI Lib "kernel32.dll" Alias "RtlMoveMemory" _
(ByVal dst As LongPtr, ByVal src As LongPtr, ByVal Length As Long)
Private Declare PtrSafe Sub CopyMemoryII Lib "kernel32.dll" Alias "RtlMoveMemory" _
(ByRef dst As SAFEARRAY, ByVal src As LongPtr, ByVal Length As Long)
DATA STRUCTS
Private Type SAFEARRAY_BOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As LongPtr
rgsabound(0) As SAFEARRAY_BOUND
End Type
Private Type SnakePart
Column As Long
Row As Long
End Type
Private Const SNAKEPART_BYTELENGTH = 8
FUNCTIONS
Private Function ArrayInsertElement(ByRef ArrayOriginal() As SnakePart, ByRef ElementToAdd As SnakePart, ByRef Position As Long) As SnakePart()
Dim NewLength As Long
Dim CopiedBytesFirstSection As Long
Dim CopiedBytesSecondSection As Long
NewLength = UBound(ArrayOriginal) + 1
ReDim ArrayInsertElement(NewLength)
CopiedBytesFirstSection = Position * SNAKEPART_BYTELENGTH
CopiedBytesSecondSection = (NewLength - Position) * SNAKEPART_BYTELENGTH
CopyMemoryI ArrayElementGetPointer(ArrayInsertElement, 0, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, 0, SNAKEPART_BYTELENGTH), CopiedBytesFirstSection
CopyMemoryI ArrayElementGetPointer(ArrayInsertElement, Position, SNAKEPART_BYTELENGTH), VarPtr(ElementToAdd), SNAKEPART_BYTELENGTH
CopyMemoryI ArrayElementGetPointer(ArrayInsertElement, Position + 1, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, Position, SNAKEPART_BYTELENGTH), CopiedBytesSecondSection
End Function
Private Function ArrayRemoveElement(ByRef ArrayOriginal() As SnakePart, ByRef Position As Long) As SnakePart()
Dim NewLength As Long
Dim CopiedBytesFirstSection As Long
Dim CopiedBytesSecondSection As Long
NewLength = UBound(ArrayOriginal) - 1
ReDim ArrayRemoveElement(NewLength)
CopiedBytesFirstSection = Position * SNAKEPART_BYTELENGTH
CopiedBytesSecondSection = (UBound(ArrayOriginal) - Position) * SNAKEPART_BYTELENGTH
CopyMemoryI ArrayElementGetPointer(ArrayRemoveElement, 0, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, 0, SNAKEPART_BYTELENGTH), CopiedBytesFirstSection
CopyMemoryI ArrayElementGetPointer(ArrayRemoveElement, Position, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, Position + 1, SNAKEPART_BYTELENGTH), CopiedBytesSecondSection
End Function
Private Function ArrayElementGetPointer(ByRef Arr() As SnakePart, ByVal ElementIndex As Long, ByVal ElementByteLength As Long) As LongPtr
Dim ptrToArrayVar As LongPtr
Dim ptrToSafeArray As LongPtr
Dim ptrToArrayData As LongPtr
Dim ptrCursor As LongPtr
Dim uSAFEARRAY As SAFEARRAY
' Get Pointer To Array *Variable*
ptrToArrayVar = VarPtrArray(Arr)
' Get Pointer To Array Variable *SAFEARRAY* By Directly Reading Array Variable
CopyMemoryI VarPtr(ptrToSafeArray), ptrToArrayVar, 8
' Read The SAFEARRAY Structure
CopyMemoryII uSAFEARRAY, ptrToSafeArray, LenB(uSAFEARRAY)
' Get Pointer To Array Data
ptrToArrayData = uSAFEARRAY.pvData
' Get Pointer To Array Element
ptrCursor = ptrToArrayData + (ElementIndex * ElementByteLength)
ArrayElementGetPointer = ptrCursor
End Function
TESTS
Private Sub ArrayInsertElementTest()
Dim x(3) As SnakePart
Dim sp As SnakePart
sp.Column = 1
sp.Row = 1
x(0) = sp
x(1) = sp
x(2) = sp
x(3) = sp
Debug.Print x(0).Column = 1
Debug.Print x(1).Column = 1
Debug.Print x(2).Column = 1
Debug.Print x(3).Column = 1
Debug.Print "_______________________"
Dim temparry() As SnakePart
temparry = x
sp.Column = 2
sp.Row = 2
temparry = ArrayInsertElement(temparry, sp, 2)
Debug.Print temparry(0).Column = 1
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 2
Debug.Print temparry(3).Column = 1
Debug.Print temparry(4).Column = 1
Debug.Print "_______________________"
sp.Column = 4
sp.Row = 4
temparry = ArrayInsertElement(temparry, sp, 4)
Debug.Print temparry(0).Column = 1
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 2
Debug.Print temparry(3).Column = 1
Debug.Print temparry(4).Column = 4
Debug.Print temparry(5).Column = 1
Debug.Print "_______________________"
sp.Column = 0
sp.Row = 0
temparry = ArrayInsertElement(temparry, sp, 0)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 1
Debug.Print temparry(3).Column = 2
Debug.Print temparry(4).Column = 1
Debug.Print temparry(5).Column = 4
Debug.Print temparry(6).Column = 1
Debug.Print "_______________________"
End Sub
Private Sub ArrayRemoveElementTest()
Dim x(5) As SnakePart
Dim sp As SnakePart
sp.Column = 0
sp.Row = 0
x(0) = sp
sp.Column = 1
sp.Row = 1
x(1) = sp
sp.Column = 2
sp.Row = 2
x(2) = sp
sp.Column = 3
sp.Row = 3
x(3) = sp
sp.Column = 4
sp.Row = 4
x(4) = sp
sp.Column = 5
sp.Row = 5
x(5) = sp
Debug.Print x(0).Column = 0
Debug.Print x(1).Column = 1
Debug.Print x(2).Column = 2
Debug.Print x(3).Column = 3
Debug.Print x(4).Column = 4
Debug.Print x(5).Column = 5
Debug.Print "_______________________"
Dim temparry() As SnakePart
temparry = x
temparry = ArrayRemoveElement(temparry, 4)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 2
Debug.Print temparry(3).Column = 3
Debug.Print temparry(4).Column = 5
Debug.Print "_______________________"
temparry = ArrayRemoveElement(temparry, 2)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 3
Debug.Print temparry(3).Column = 5
Debug.Print "_______________________"
temparry = ArrayRemoveElement(temparry, 1)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 3
Debug.Print temparry(2).Column = 5
Debug.Print "_______________________"
temparry = ArrayRemoveElement(temparry, 0)
Debug.Print temparry(0).Column = 3
Debug.Print temparry(1).Column = 5
Debug.Print "_______________________"
End Sub
performance vba excel winapi
asked 2 days ago
learnAsWeGolearnAsWeGo
2987
$endgroup$
add a comment |
2
2
2
$begingroup$
An extension to array functions I am building for my snake game. This one allows you to remove / insert particular elements.
API CALLS
Private Declare PtrSafe Function VarPtrArray Lib "VBE7" Alias "VarPtr" _
(ByRef Var() As Any) As LongPtr
Private Declare PtrSafe Sub CopyMemoryI Lib "kernel32.dll" Alias "RtlMoveMemory" _
(ByVal dst As LongPtr, ByVal src As LongPtr, ByVal Length As Long)
Private Declare PtrSafe Sub CopyMemoryII Lib "kernel32.dll" Alias "RtlMoveMemory" _
(ByRef dst As SAFEARRAY, ByVal src As LongPtr, ByVal Length As Long)
DATA STRUCTS
Private Type SAFEARRAY_BOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As LongPtr
rgsabound(0) As SAFEARRAY_BOUND
End Type
Private Type SnakePart
Column As Long
Row As Long
End Type
Private Const SNAKEPART_BYTELENGTH = 8
FUNCTIONS
Private Function ArrayInsertElement(ByRef ArrayOriginal() As SnakePart, ByRef ElementToAdd As SnakePart, ByRef Position As Long) As SnakePart()
Dim NewLength As Long
Dim CopiedBytesFirstSection As Long
Dim CopiedBytesSecondSection As Long
NewLength = UBound(ArrayOriginal) + 1
ReDim ArrayInsertElement(NewLength)
CopiedBytesFirstSection = Position * SNAKEPART_BYTELENGTH
CopiedBytesSecondSection = (NewLength - Position) * SNAKEPART_BYTELENGTH
CopyMemoryI ArrayElementGetPointer(ArrayInsertElement, 0, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, 0, SNAKEPART_BYTELENGTH), CopiedBytesFirstSection
CopyMemoryI ArrayElementGetPointer(ArrayInsertElement, Position, SNAKEPART_BYTELENGTH), VarPtr(ElementToAdd), SNAKEPART_BYTELENGTH
CopyMemoryI ArrayElementGetPointer(ArrayInsertElement, Position + 1, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, Position, SNAKEPART_BYTELENGTH), CopiedBytesSecondSection
End Function
Private Function ArrayRemoveElement(ByRef ArrayOriginal() As SnakePart, ByRef Position As Long) As SnakePart()
Dim NewLength As Long
Dim CopiedBytesFirstSection As Long
Dim CopiedBytesSecondSection As Long
NewLength = UBound(ArrayOriginal) - 1
ReDim ArrayRemoveElement(NewLength)
CopiedBytesFirstSection = Position * SNAKEPART_BYTELENGTH
CopiedBytesSecondSection = (UBound(ArrayOriginal) - Position) * SNAKEPART_BYTELENGTH
CopyMemoryI ArrayElementGetPointer(ArrayRemoveElement, 0, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, 0, SNAKEPART_BYTELENGTH), CopiedBytesFirstSection
CopyMemoryI ArrayElementGetPointer(ArrayRemoveElement, Position, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, Position + 1, SNAKEPART_BYTELENGTH), CopiedBytesSecondSection
End Function
Private Function ArrayElementGetPointer(ByRef Arr() As SnakePart, ByVal ElementIndex As Long, ByVal ElementByteLength As Long) As LongPtr
Dim ptrToArrayVar As LongPtr
Dim ptrToSafeArray As LongPtr
Dim ptrToArrayData As LongPtr
Dim ptrCursor As LongPtr
Dim uSAFEARRAY As SAFEARRAY
' Get Pointer To Array *Variable*
ptrToArrayVar = VarPtrArray(Arr)
' Get Pointer To Array Variable *SAFEARRAY* By Directly Reading Array Variable
CopyMemoryI VarPtr(ptrToSafeArray), ptrToArrayVar, 8
' Read The SAFEARRAY Structure
CopyMemoryII uSAFEARRAY, ptrToSafeArray, LenB(uSAFEARRAY)
' Get Pointer To Array Data
ptrToArrayData = uSAFEARRAY.pvData
' Get Pointer To Array Element
ptrCursor = ptrToArrayData + (ElementIndex * ElementByteLength)
ArrayElementGetPointer = ptrCursor
End Function
TESTS
Private Sub ArrayInsertElementTest()
Dim x(3) As SnakePart
Dim sp As SnakePart
sp.Column = 1
sp.Row = 1
x(0) = sp
x(1) = sp
x(2) = sp
x(3) = sp
Debug.Print x(0).Column = 1
Debug.Print x(1).Column = 1
Debug.Print x(2).Column = 1
Debug.Print x(3).Column = 1
Debug.Print "_______________________"
Dim temparry() As SnakePart
temparry = x
sp.Column = 2
sp.Row = 2
temparry = ArrayInsertElement(temparry, sp, 2)
Debug.Print temparry(0).Column = 1
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 2
Debug.Print temparry(3).Column = 1
Debug.Print temparry(4).Column = 1
Debug.Print "_______________________"
sp.Column = 4
sp.Row = 4
temparry = ArrayInsertElement(temparry, sp, 4)
Debug.Print temparry(0).Column = 1
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 2
Debug.Print temparry(3).Column = 1
Debug.Print temparry(4).Column = 4
Debug.Print temparry(5).Column = 1
Debug.Print "_______________________"
sp.Column = 0
sp.Row = 0
temparry = ArrayInsertElement(temparry, sp, 0)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 1
Debug.Print temparry(3).Column = 2
Debug.Print temparry(4).Column = 1
Debug.Print temparry(5).Column = 4
Debug.Print temparry(6).Column = 1
Debug.Print "_______________________"
End Sub
Private Sub ArrayRemoveElementTest()
Dim x(5) As SnakePart
Dim sp As SnakePart
sp.Column = 0
sp.Row = 0
x(0) = sp
sp.Column = 1
sp.Row = 1
x(1) = sp
sp.Column = 2
sp.Row = 2
x(2) = sp
sp.Column = 3
sp.Row = 3
x(3) = sp
sp.Column = 4
sp.Row = 4
x(4) = sp
sp.Column = 5
sp.Row = 5
x(5) = sp
Debug.Print x(0).Column = 0
Debug.Print x(1).Column = 1
Debug.Print x(2).Column = 2
Debug.Print x(3).Column = 3
Debug.Print x(4).Column = 4
Debug.Print x(5).Column = 5
Debug.Print "_______________________"
Dim temparry() As SnakePart
temparry = x
temparry = ArrayRemoveElement(temparry, 4)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 2
Debug.Print temparry(3).Column = 3
Debug.Print temparry(4).Column = 5
Debug.Print "_______________________"
temparry = ArrayRemoveElement(temparry, 2)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 3
Debug.Print temparry(3).Column = 5
Debug.Print "_______________________"
temparry = ArrayRemoveElement(temparry, 1)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 3
Debug.Print temparry(2).Column = 5
Debug.Print "_______________________"
temparry = ArrayRemoveElement(temparry, 0)
Debug.Print temparry(0).Column = 3
Debug.Print temparry(1).Column = 5
Debug.Print "_______________________"
End Sub
performance vba excel winapi
asked 2 days ago
learnAsWeGolearnAsWeGo
2987
$endgroup$
An extension to array functions I am building for my snake game. This one allows you to remove / insert particular elements.
API CALLS
Private Declare PtrSafe Function VarPtrArray Lib "VBE7" Alias "VarPtr" _
(ByRef Var() As Any) As LongPtr
Private Declare PtrSafe Sub CopyMemoryI Lib "kernel32.dll" Alias "RtlMoveMemory" _
(ByVal dst As LongPtr, ByVal src As LongPtr, ByVal Length As Long)
Private Declare PtrSafe Sub CopyMemoryII Lib "kernel32.dll" Alias "RtlMoveMemory" _
(ByRef dst As SAFEARRAY, ByVal src As LongPtr, ByVal Length As Long)
DATA STRUCTS
Private Type SAFEARRAY_BOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As LongPtr
rgsabound(0) As SAFEARRAY_BOUND
End Type
Private Type SnakePart
Column As Long
Row As Long
End Type
Private Const SNAKEPART_BYTELENGTH = 8
FUNCTIONS
Private Function ArrayInsertElement(ByRef ArrayOriginal() As SnakePart, ByRef ElementToAdd As SnakePart, ByRef Position As Long) As SnakePart()
Dim NewLength As Long
Dim CopiedBytesFirstSection As Long
Dim CopiedBytesSecondSection As Long
NewLength = UBound(ArrayOriginal) + 1
ReDim ArrayInsertElement(NewLength)
CopiedBytesFirstSection = Position * SNAKEPART_BYTELENGTH
CopiedBytesSecondSection = (NewLength - Position) * SNAKEPART_BYTELENGTH
CopyMemoryI ArrayElementGetPointer(ArrayInsertElement, 0, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, 0, SNAKEPART_BYTELENGTH), CopiedBytesFirstSection
CopyMemoryI ArrayElementGetPointer(ArrayInsertElement, Position, SNAKEPART_BYTELENGTH), VarPtr(ElementToAdd), SNAKEPART_BYTELENGTH
CopyMemoryI ArrayElementGetPointer(ArrayInsertElement, Position + 1, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, Position, SNAKEPART_BYTELENGTH), CopiedBytesSecondSection
End Function
Private Function ArrayRemoveElement(ByRef ArrayOriginal() As SnakePart, ByRef Position As Long) As SnakePart()
Dim NewLength As Long
Dim CopiedBytesFirstSection As Long
Dim CopiedBytesSecondSection As Long
NewLength = UBound(ArrayOriginal) - 1
ReDim ArrayRemoveElement(NewLength)
CopiedBytesFirstSection = Position * SNAKEPART_BYTELENGTH
CopiedBytesSecondSection = (UBound(ArrayOriginal) - Position) * SNAKEPART_BYTELENGTH
CopyMemoryI ArrayElementGetPointer(ArrayRemoveElement, 0, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, 0, SNAKEPART_BYTELENGTH), CopiedBytesFirstSection
CopyMemoryI ArrayElementGetPointer(ArrayRemoveElement, Position, SNAKEPART_BYTELENGTH), ArrayElementGetPointer(ArrayOriginal, Position + 1, SNAKEPART_BYTELENGTH), CopiedBytesSecondSection
End Function
Private Function ArrayElementGetPointer(ByRef Arr() As SnakePart, ByVal ElementIndex As Long, ByVal ElementByteLength As Long) As LongPtr
Dim ptrToArrayVar As LongPtr
Dim ptrToSafeArray As LongPtr
Dim ptrToArrayData As LongPtr
Dim ptrCursor As LongPtr
Dim uSAFEARRAY As SAFEARRAY
' Get Pointer To Array *Variable*
ptrToArrayVar = VarPtrArray(Arr)
' Get Pointer To Array Variable *SAFEARRAY* By Directly Reading Array Variable
CopyMemoryI VarPtr(ptrToSafeArray), ptrToArrayVar, 8
' Read The SAFEARRAY Structure
CopyMemoryII uSAFEARRAY, ptrToSafeArray, LenB(uSAFEARRAY)
' Get Pointer To Array Data
ptrToArrayData = uSAFEARRAY.pvData
' Get Pointer To Array Element
ptrCursor = ptrToArrayData + (ElementIndex * ElementByteLength)
ArrayElementGetPointer = ptrCursor
End Function
TESTS
Private Sub ArrayInsertElementTest()
Dim x(3) As SnakePart
Dim sp As SnakePart
sp.Column = 1
sp.Row = 1
x(0) = sp
x(1) = sp
x(2) = sp
x(3) = sp
Debug.Print x(0).Column = 1
Debug.Print x(1).Column = 1
Debug.Print x(2).Column = 1
Debug.Print x(3).Column = 1
Debug.Print "_______________________"
Dim temparry() As SnakePart
temparry = x
sp.Column = 2
sp.Row = 2
temparry = ArrayInsertElement(temparry, sp, 2)
Debug.Print temparry(0).Column = 1
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 2
Debug.Print temparry(3).Column = 1
Debug.Print temparry(4).Column = 1
Debug.Print "_______________________"
sp.Column = 4
sp.Row = 4
temparry = ArrayInsertElement(temparry, sp, 4)
Debug.Print temparry(0).Column = 1
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 2
Debug.Print temparry(3).Column = 1
Debug.Print temparry(4).Column = 4
Debug.Print temparry(5).Column = 1
Debug.Print "_______________________"
sp.Column = 0
sp.Row = 0
temparry = ArrayInsertElement(temparry, sp, 0)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 1
Debug.Print temparry(3).Column = 2
Debug.Print temparry(4).Column = 1
Debug.Print temparry(5).Column = 4
Debug.Print temparry(6).Column = 1
Debug.Print "_______________________"
End Sub
Private Sub ArrayRemoveElementTest()
Dim x(5) As SnakePart
Dim sp As SnakePart
sp.Column = 0
sp.Row = 0
x(0) = sp
sp.Column = 1
sp.Row = 1
x(1) = sp
sp.Column = 2
sp.Row = 2
x(2) = sp
sp.Column = 3
sp.Row = 3
x(3) = sp
sp.Column = 4
sp.Row = 4
x(4) = sp
sp.Column = 5
sp.Row = 5
x(5) = sp
Debug.Print x(0).Column = 0
Debug.Print x(1).Column = 1
Debug.Print x(2).Column = 2
Debug.Print x(3).Column = 3
Debug.Print x(4).Column = 4
Debug.Print x(5).Column = 5
Debug.Print "_______________________"
Dim temparry() As SnakePart
temparry = x
temparry = ArrayRemoveElement(temparry, 4)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 2
Debug.Print temparry(3).Column = 3
Debug.Print temparry(4).Column = 5
Debug.Print "_______________________"
temparry = ArrayRemoveElement(temparry, 2)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 1
Debug.Print temparry(2).Column = 3
Debug.Print temparry(3).Column = 5
Debug.Print "_______________________"
temparry = ArrayRemoveElement(temparry, 1)
Debug.Print temparry(0).Column = 0
Debug.Print temparry(1).Column = 3
Debug.Print temparry(2).Column = 5
Debug.Print "_______________________"
temparry = ArrayRemoveElement(temparry, 0)
Debug.Print temparry(0).Column = 3
Debug.Print temparry(1).Column = 5
Debug.Print "_______________________"
End Sub
performance vba excel winapi
performance vba excel winapi
asked 2 days ago
learnAsWeGolearnAsWeGo
2987
asked 2 days ago
learnAsWeGolearnAsWeGo
2987
edited 8 mins ago
learnAsWeGo
asked 2 days ago
learnAsWeGolearnAsWeGo
2987
asked 2 days ago
learnAsWeGolearnAsWeGo
2987
asked 2 days ago
learnAsWeGolearnAsWeGo
2987
2987
add a comment |
add a comment |
0
active
oldest
votes
Your Answer
StackExchange.ifUsing("editor", function ()
return StackExchange.using("mathjaxEditing", function ()
StackExchange.MarkdownEditor.creationCallbacks.add(function (editor, postfix)
StackExchange.mathjaxEditing.prepareWmdForMathJax(editor, postfix, [["\$", "\$"]]);
);
);
, "mathjax-editing");
StackExchange.ifUsing("editor", function ()
StackExchange.using("externalEditor", function ()
StackExchange.using("snippets", function ()
StackExchange.snippets.init();
);
);
, "code-snippets");
StackExchange.ready(function()
var channelOptions =
tags: "".split(" "),
id: "196"
;
initTagRenderer("".split(" "), "".split(" "), channelOptions);
StackExchange.using("externalEditor", function()
// Have to fire editor after snippets, if snippets enabled
if (StackExchange.settings.snippets.snippetsEnabled)
StackExchange.using("snippets", function()
createEditor();
);
else
createEditor();
);
function createEditor()
StackExchange.prepareEditor(
heartbeatType: 'answer',
autoActivateHeartbeat: false,
convertImagesToLinks: false,
noModals: true,
showLowRepImageUploadWarning: true,
reputationToPostImages: null,
bindNavPrevention: true,
postfix: "",
imageUploader:
brandingHtml: "Powered by u003ca class="icon-imgur-white" href="https://imgur.com/"u003eu003c/au003e",
contentPolicyHtml: "User contributions licensed under u003ca href="https://creativecommons.org/licenses/by-sa/3.0/"u003ecc by-sa 3.0 with attribution requiredu003c/au003e u003ca href="https://stackoverflow.com/legal/content-policy"u003e(content policy)u003c/au003e",
allowUrls: true
,
onDemand: true,
discardSelector: ".discard-answer"
,immediatelyShowMarkdownHelp:true
);
);
draft saved
draft discarded
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
var $window = $(window),
onScroll = function(e)
var $elem = $('.new-login-left'),
docViewTop = $window.scrollTop(),
docViewBottom = docViewTop + $window.height(),
elemTop = $elem.offset().top,
elemBottom = elemTop + $elem.height();
if ((docViewTop elemBottom))
StackExchange.using('gps', function() StackExchange.gps.track('embedded_signup_form.view', location: 'question_page' ); );
$window.unbind('scroll', onScroll);
;
$window.on('scroll', onScroll);
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function ()
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fcodereview.stackexchange.com%2fquestions%2f216385%2fvba-array-functions-insert-element-remove-element%23new-answer', 'question_page');
);
Post as a guest
Required, but never shown
0
active
oldest
votes
0
active
oldest
votes
active
oldest
votes
active
oldest
votes
draft saved
draft discarded
Thanks for contributing an answer to Code Review Stack Exchange!
- Please be sure to answer the question. Provide details and share your research!
But avoid …
- Asking for help, clarification, or responding to other answers.
- Making statements based on opinion; back them up with references or personal experience.
Use MathJax to format equations. MathJax reference.
To learn more, see our tips on writing great answers.
draft saved
draft discarded
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
var $window = $(window),
onScroll = function(e)
var $elem = $('.new-login-left'),
docViewTop = $window.scrollTop(),
docViewBottom = docViewTop + $window.height(),
elemTop = $elem.offset().top,
elemBottom = elemTop + $elem.height();
if ((docViewTop elemBottom))
StackExchange.using('gps', function() StackExchange.gps.track('embedded_signup_form.view', location: 'question_page' ); );
$window.unbind('scroll', onScroll);
;
$window.on('scroll', onScroll);
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function ()
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fcodereview.stackexchange.com%2fquestions%2f216385%2fvba-array-functions-insert-element-remove-element%23new-answer', 'question_page');
);
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
var $window = $(window),
onScroll = function(e)
var $elem = $('.new-login-left'),
docViewTop = $window.scrollTop(),
docViewBottom = docViewTop + $window.height(),
elemTop = $elem.offset().top,
elemBottom = elemTop + $elem.height();
if ((docViewTop elemBottom))
StackExchange.using('gps', function() StackExchange.gps.track('embedded_signup_form.view', location: 'question_page' ); );
$window.unbind('scroll', onScroll);
;
$window.on('scroll', onScroll);
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
var $window = $(window),
onScroll = function(e)
var $elem = $('.new-login-left'),
docViewTop = $window.scrollTop(),
docViewBottom = docViewTop + $window.height(),
elemTop = $elem.offset().top,
elemBottom = elemTop + $elem.height();
if ((docViewTop elemBottom))
StackExchange.using('gps', function() StackExchange.gps.track('embedded_signup_form.view', location: 'question_page' ); );
$window.unbind('scroll', onScroll);
;
$window.on('scroll', onScroll);
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
var $window = $(window),
onScroll = function(e)
var $elem = $('.new-login-left'),
docViewTop = $window.scrollTop(),
docViewBottom = docViewTop + $window.height(),
elemTop = $elem.offset().top,
elemBottom = elemTop + $elem.height();
if ((docViewTop elemBottom))
StackExchange.using('gps', function() StackExchange.gps.track('embedded_signup_form.view', location: 'question_page' ); );
$window.unbind('scroll', onScroll);
;
$window.on('scroll', onScroll);
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
