Skip to content

Instantly share code, notes, and snippets.

@furyutei

furyutei/0.README.md

Last active December 5, 2024 12:58
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save furyutei/697f57cb6a83ef1f558b5e0767bd8d06 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save furyutei/697f57cb6a83ef1f558b5e0767bd8d06 to your computer and use it in GitHub Desktop.
Download ZIP
[VBA] 配列の全次元の添字の下限を一括設定するプロシージャを試作
Raw
0.README.md

[VBA] 配列の全次元の添字の下限を一括設定するプロシージャを試作

Arr(0 To 2, 2 To 5)
みたいな(動的)配列を
Arr(1 To 3, 1 To 4)
のように要素数は変えずに添字だけを全次元一括して変える試み。

なお、配列の添字下限は、1次元配列であれば、
ReDim Preserve Arr(Base To Base + UBound(Arr) - LBound(Arr))
のようにして変更できる。
ただし、ReDim Preserveの場合は最後の次元しか変更できないという制限がある。

「Option Base 1」を宣言していても、Baseが0のままの配列が出来てしまうことはままあるので、いちいちBaseがいくつかを考えずに一括で揃えておけば使いやすいんじゃないか、と考えた。
Base 1ならUBoundのみで要素数が取れるし。

ただし、静的配列の場合、やや動作変なのでデフォルトでは書き換えないようにした（ApplyToFixedArrayをTrueにすれば静的配列でも適用される）。
※静的配列に適用すると、LBound/UBoundで返される値や実際に添え字を指定して返される値は変化するものの、なぜかローカルウィンドウで見ると添え字範囲が元のままになっている。

プロシージャ仕様

Public Function RebaseArray(ByRef TargetArray As Variant, Optional ByVal Base As Long = 1, Optional ApplyToFixedArray As Boolean = False) As Long

パラメータ
---
TargetArray
　対象となる配列
　※直接書き換えられることに注意
 
Base
　設定する添字の下限
　※値範囲のチェックは行っていないことに注意

ApplyToFixedArray
  静的配列に対しても適用する場合はTrue
  ※[TODO] 静的配列に適用すると、ローカル／ウォッチウィンドウでの添字表示が実行中のものと合わなくなってしまう

戻り値
---
0: 正常
-1: 配列以外が指定された
-2: 未初期化の配列が指定された
-3: 静的配列が指定された
Raw
Mod_RebaseArray.vba
Option Explicit
' 参考: [How Visual Basic 6 Stores Data | CodeGuru](https://www.codeguru.com/visual-basic/how-visual-basic-6-stores-data/)
Private Declare PtrSafe Sub RtlMoveMemory Lib "Kernel32" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As LongPtr)
Private Type ArrayBase
cDim As Integer ' A count of the number of dimensions in the array.
fFeature As Integer ' Flags
cbElements As Long ' Size of each element in the array.
cLocks As Long ' Used to lock the array.
pvData As LongPtr ' A pointer to the first data element in the array.
rgsabound As Variant ' Safe_Array_Bound array. ※cDim個のSafe_Array_Boundが一番右の次元→左の次元の順に並ぶ
End Type
Private Type Safe_Array_Bound
cElements As Long ' The number of elements in the dimension.
lLbound As Long ' The lower bound of the dimension.
End Type
Private Enum ArrayFeatureFlag
FADF_AUTO = &H1& ' Array is allocated on the stack.
FADF_STATIC = &H2& ' Array is statically allocated.
FADF_EMBEDDED = &H4& ' Array is embedded in a structure.
FADF_FIXEDSIZE = &H10& ' Array may not be resized or reallocated.
FADF_BSTR = &H100& ' An array of BSTRs.
FADF_UNKNOWN = &H200& ' An array of IUnknown*.
FADF_DISPATCH = &H400& ' An array of IDispatch*.
FADF_VARIANT = &H800& ' An array of VARIANTs.
FADF_RESERVED = &HF0E8& ' Bits reserved for future use.
End Enum
Public Function RebaseArray(ByRef TargetArray As Variant, Optional ByVal Base As Long = 1, Optional ApplyToFixedArray As Boolean = False) As Long
Const RET_OK As Long = 0
Const RET_NOT_ARRAY As Long = -1
Const RET_NOT_INITIALIZED As Long = -2
Const RET_FIXED_ARRAY As Long = -3
Const VT_ARRAY As Integer = vbArray ' &H2000
Const VT_BYREF As Integer = &H4000
Const PARRAY_OFFSET As LongPtr = 8 ' vt(VARTYPE:2 bytes)+(WORD:2 bytes)×3
Dim vt As Integer
Dim pArray As LongPtr
Call RtlMoveMemory(vt, TargetArray, LenB(vt))
If (vt And VT_ARRAY) = &H0 Then
RebaseArray = RET_NOT_ARRAY
Exit Function
End If
Call RtlMoveMemory(pArray, ByVal (VarPtr(TargetArray) + PARRAY_OFFSET), LenB(pArray))
If (vt And VT_BYREF) = VT_BYREF Then
Call RtlMoveMemory(pArray, ByVal pArray, LenB(pArray))
End If
If pArray = 0 Then
RebaseArray = RET_NOT_INITIALIZED
Exit Function
End If
Dim TargetArrayBase As ArrayBase
Dim BoundArrayOffset As LongPtr: BoundArrayOffset = VarPtr(TargetArrayBase.rgsabound) - VarPtr(TargetArrayBase.cDim)
Call RtlMoveMemory(TargetArrayBase, ByVal pArray, BoundArrayOffset)
If Not ApplyToFixedArray Then
' [TODO] 静的配列の場合でも書き換えは可能ではあるが、VBEのローカルウィンドウ等で見ると添字は変わらないように見えている
If (TargetArrayBase.fFeature And FADF_FIXEDSIZE) = FADF_FIXEDSIZE Then
RebaseArray = RET_FIXED_ARRAY
Exit Function
End If
End If
Dim BoundInfo As Safe_Array_Bound
Dim BoundInfoSize As LongPtr: BoundInfoSize = LenB(BoundInfo)
Dim Index As Long
Dim pBound As LongPtr
For Index = 0 To TargetArrayBase.cDim - 1
pBound = pArray + BoundArrayOffset + BoundInfoSize * CLngPtr(Index)
Call RtlMoveMemory(BoundInfo, ByVal pBound, BoundInfoSize)
BoundInfo.lLbound = Base
Call RtlMoveMemory(ByVal pBound, BoundInfo, BoundInfoSize)
Next
RebaseArray = RET_OK
End Function
Raw
Mod_TestRebaseArray.vba
Option Explicit
Sub TestRebaseArray()
Dim Arr As Variant
Arr = VBA.Array(1, 2, 3)
Debug.Print "[Before]", LBound(Arr, 1), UBound(Arr, 1)
Call RebaseArray(Arr, Base:=1)
Debug.Print "[After]", LBound(Arr, 1), UBound(Arr, 1)
Stop
Arr = ActiveSheet.Cells(1, 1).Resize(5, 3)
Debug.Print "[Before]", LBound(Arr, 1), UBound(Arr, 1), LBound(Arr, 2), UBound(Arr, 2)
Call RebaseArray(Arr, Base:=0)
Debug.Print "[After]", LBound(Arr, 1), UBound(Arr, 1), LBound(Arr, 2), UBound(Arr, 2)
Stop
Dim SArr(0 To 4, 2 To 5): SArr(0, 2) = 1: SArr(4, 5) = 99
Debug.Print "[Before]", LBound(SArr, 1), UBound(SArr, 1)
Call RebaseArray(SArr, Base:=1) ' デフォルトでは静的配列は対象外
Debug.Print "[After]", LBound(SArr, 1), UBound(SArr, 1)
Stop
Arr = SArr ' 一度動的配列にしてからなら変換
Debug.Print "[Before]", LBound(Arr, 1), UBound(Arr, 1)
Call RebaseArray(Arr, Base:=1)
Debug.Print "[After]", LBound(Arr, 1), UBound(Arr, 1)
Stop
Debug.Print "[Before]", LBound(SArr, 1), UBound(SArr, 1)
Call RebaseArray(SArr, Base:=1, ApplyToFixedArray:=True) ' 静的配列も強制的に処理
Debug.Print "[After]", LBound(SArr, 1), UBound(SArr, 1)
Debug.Print "SArr(1,1)=" & SArr(1, 1), "SArr(5,4)=" & SArr(5, 4) ' [TODO] ローカルウィンドウで見ると添字は元のまま
Stop
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment