[Excel][VBA] RECT型（ユーザー定義型）変数とクラスモジュール間で値をダイレクトにやり取りする試み

0.README.md

[Excel][VBA] RECT型（ユーザー定義型）変数とクラスモジュール間で値をダイレクトにやり取りする試み

ことりちゅん さんのモジュールを参考にして、

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

のようなユーザー定義型（RECT型）を扱いやすくするクラスモジュール（Rectangle）を試作してみた。

元々の機能に加えて

• RECT型変数の値を直接指定可能
• RECT型変数へ値を代入可能

となっている。

ソースコード

1. Rectangle クラス モジュール（Rectangle.cls）
2. テスト用標準モジュール (TestRect_Module.bas)

使用例

Dim work_rectangle As New Rectangle

' Left, Top, Right, Bottom の値を指定
Call work_rectangle.Init(10, 20, 30, 40)

' 複製作成
Dim dest_rectangle As Rectangle
Set dest_rectangle = work_rectangle.Clone

' RECT型変数を直接指定
Dim work_rect As RECT
' : work_rect の初期化処理など
work_rectangle.RectValue = work_rect

' RECT型変数に設定
work_rect = work_rectangle.RectValue

元ネタ

• ことりちゅん@KotorinChunChun さんのツイート
• VBAのクラスの作り方1 - 進化するRECT - えくせるちゅんちゅん

Rectangle.cls

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32.dll" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As LongPtr)
#Else
    Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
#End If

' ■ RECT型について
'
' - RECT型は標準モジュール内にてPublicで定義しておくこと
'
' - RECT型の定義は下記のように複数存在しうる（どちらで定義されていてもよい）
'
'   - Left方式
'        Type RECT
'            Left As Long
'            Top As Long
'            Right As Long
'            Bottom As Long
'        End Type
'
'   - XY方式
'        Type RECT
'            X1 As Long
'            Y1 As Long
'            X2 As Long
'            Y2 As Long
'        End Type

Private Type RECT_MAP
    Value(0 To 4) As Long
    ' Value(0) : X1 / Left
    ' Value(1) : Y1 / Top
    ' Value(2) : X2 / Right
    ' Value(3) : Y2 / Bottom
End Type

Private RefRect As RECT_MAP

Private CurrentRectValue As RECT

Friend Sub SetRect(SourceRectValue As RECT)
    CurrentRectValue = SourceRectValue
End Sub


' 初期化
Public Function Init(Left As Long, Top As Long, Right As Long, Bottom As Long) As Rectangle
    With Me
        .Left = Left
        .Top = Top
        .Right = Right
        .Bottom = Bottom
    End With
    Set Init = Me
End Function

' 複製
Public Function Clone() As Rectangle
    Dim dest_rect As Rectangle: Set dest_rect = New Rectangle
    
    ' オブジェクト間で RECT 型受け渡し
    ' 参考：[class - Assignment of objects in VB6 - Stack Overflow](https://stackoverflow.com/questions/4805475/assignment-of-objects-in-vb6/4805812#4805812)
    Call dest_rect.SetRect(CurrentRectValue)
    
    Set Clone = dest_rect
End Function

' RECT型で取得
Public Property Get RectValue() As RECT
    RectValue = CurrentRectValue
End Property

' RECT型で指定
Public Property Let RectValue(Value As RECT)
    CurrentRectValue = Value
End Property

' LEFT方式（取得／設定）
Public Property Get Left() As Long
    Call RtlMoveMemory(VarPtr(Left), VarPtr(CurrentRectValue) + (VarPtr(RefRect.Value(0)) - VarPtr(RefRect)), 4)
End Property

Public Property Let Left(Value As Long)
    Call RtlMoveMemory(VarPtr(CurrentRectValue) + (VarPtr(RefRect.Value(0)) - VarPtr(RefRect)), VarPtr(Value), 4)
End Property

Public Property Get Top() As Long
    Call RtlMoveMemory(VarPtr(Top), VarPtr(CurrentRectValue) + (VarPtr(RefRect.Value(1)) - VarPtr(RefRect)), 4)
End Property

Public Property Let Top(Value As Long)
    Call RtlMoveMemory(VarPtr(CurrentRectValue) + (VarPtr(RefRect.Value(1)) - VarPtr(RefRect)), VarPtr(Value), 4)
End Property

Public Property Get Right() As Long
    Call RtlMoveMemory(VarPtr(Right), VarPtr(CurrentRectValue) + (VarPtr(RefRect.Value(2)) - VarPtr(RefRect)), 4)
End Property

Public Property Let Right(Value As Long)
    Call RtlMoveMemory(VarPtr(CurrentRectValue) + (VarPtr(RefRect.Value(2)) - VarPtr(RefRect)), VarPtr(Value), 4)
End Property

Public Property Get Bottom() As Long
    Call RtlMoveMemory(VarPtr(Bottom), VarPtr(CurrentRectValue) + (VarPtr(RefRect.Value(3)) - VarPtr(RefRect)), 4)
End Property

Public Property Let Bottom(Value As Long)
    Call RtlMoveMemory(VarPtr(CurrentRectValue) + (VarPtr(RefRect.Value(3)) - VarPtr(RefRect)), VarPtr(Value), 4)
End Property

' XY 方式（取得／設定）
Public Property Get X1() As Long: X1 = Left: End Property
Public Property Get X2() As Long: X2 = Right: End Property
Public Property Get Y1() As Long: Y1 = Top: End Property
Public Property Get Y2() As Long: Y2 = Bottom: End Property
Public Property Let X1(Value As Long): Left = Value: End Property
Public Property Let X2(Value As Long): Right = Value: End Property
Public Property Let Y1(Value As Long): Top = Value: End Property
Public Property Let Y2(Value As Long): Bottom = Value: End Property

' 幅
Public Property Get Width()
    Width = Abs(Right - Left)
End Property

' 高さ
Public Property Get Height()
    Height = Abs(Top - Bottom)
End Property

' 長辺の長さ
Public Property Get LongSide()
    LongSide = IIf(Width > Height, Width, Height)
End Property

' 短辺の長さ
Public Property Get ShortSide()
    ShortSide = IIf(Width < Height, Width, Height)
End Property

' 矩形の中央
Public Property Get CenterPoint()
    ReDim ret(1 To 2)
    ret(1) = (Left + Right) / 2
    ret(2) = (Top + Bottom) / 2
    CenterPoint = ret
End Property

' 情報の取得
Public Property Get ToString() As String
    ToString = Join(Array( _
        "Left  : " & Left, _
        "Right : " & Right, _
        "Top   : " & Top, _
        "Bottom: " & Bottom, _
        "", _
        "Width : " & Width, _
        "Height: " & Height, _
        "", _
        "ShortSide : " & ShortSide, _
        "LongSide  : " & LongSide, _
        "", _
        "CenterPoint : " & CenterPoint(1) & " , " & CenterPoint(2), _
        ""), vbLf)
End Property

TestRect_Module.bas

Option Explicit

' 条件付きコンパイル(RECT_TYPE に RECT_TYPE_LEFT もしくは RECT_TYPE_XY を指定

#Const RECT_TYPE_LEFT = 1
#Const RECT_TYPE_XY = 2

#Const RECT_TYPE = RECT_TYPE_LEFT
'#Const RECT_TYPE = RECT_TYPE_XY

#If RECT_TYPE = RECT_TYPE_XY Then
Type RECT
    X1 As Long
    Y1 As Long
    X2 As Long
    Y2 As Long
End Type
#Else
Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
#End If


Sub TestRECT()
    Dim dic As Object
    Dim work_rectangle As Rectangle
    Dim work_rect As RECT
    Dim dic_key

#If RECT_TYPE = RECT_TYPE_XY Then
    Debug.Print "※ RECT は XY型" & vbLf
#Else
    Debug.Print "※ RECT は Left型" & vbLf
#End If

    Set dic = CreateObject("Scripting.Dictionary")

    With New Rectangle
        Call .Init(1, 2, 3, 4)
        Debug.Print "<元>"
        Debug.Print .ToString
        Debug.Print "---"

        'dic.Add "a", .Clone.Init(1, 2, 3, 4)
        dic.Add "a", .Clone
        dic.Add "b", .Clone.Init(5, 6, 70, 80)
        dic.Add "c", .Clone.Init(9, 10, 110, 120)
        dic.Add "d", .Clone.Init(13, 14, 150, 160)
    End With

    For Each dic_key In dic
        Debug.Print "<" & dic_key & ">"
        Debug.Print dic.Item(dic_key).ToString
        Debug.Print "---"
    Next dic_key

    With work_rect
#If RECT_TYPE = RECT_TYPE_XY Then
        .X1 = 10
        .Y1 = 20
        .X2 = 30
        .Y2 = 40
#Else
        .Left = 10
        .Top = 20
        .Right = 30
        .Bottom = 40
#End If
    End With

    Set work_rectangle = dic.Item("a")
    '※ RECT型にアクセスする場合のみ、dic.Item("a").RectValue と書くとエラーになるため、一旦変数にセットする必要あり

    ' RECT 型変数の値を Rectangle オブジェクトにダイレクトに設定
    work_rectangle.RectValue = work_rect

    Debug.Print "<a> .RectValue に RECT型変数を代入後"
    Debug.Print dic.Item("a").ToString
    Debug.Print "---"

    With work_rectangle
        .Left = 100
        .Top = 200
        .Right = 300
        .Bottom = 400
    End With

    Debug.Print "<a> 各プロパティ（.Left, .Top, .Right, .Bottom）個別設定後"
    With dic.Item("a") ' work_rectangle と dic.Item("a") が同じものを指していることの証明
        Debug.Print .ToString
        Debug.Print ""
        Debug.Print "X1: " & .X1
        Debug.Print "X2: " & .X2
        Debug.Print "Y1: " & .Y1
        Debug.Print "Y2: " & .Y2
        Debug.Print "---"
    End With

    ' Rectangle オブジェクトから RECT 型変数へダイレクトに設定
    work_rect = work_rectangle.RectValue

    With work_rect
        Debug.Print "<RECT型変数> ※ Rectangle オブジェクトから RECT 型変数へダイレクトに代入した結果"

#If RECT_TYPE = RECT_TYPE_XY Then
        Debug.Print "X1: " & .X1
        Debug.Print "X2: " & .X2
        Debug.Print "Y1: " & .Y1
        Debug.Print "Y2: " & .Y2
#Else
        Debug.Print "Left:   " & .Left
        Debug.Print "Right:  " & .Right
        Debug.Print "Top:    " & .Top
        Debug.Print "Bottom: " & .Bottom
#End If
    End With

    Stop
End Sub

TestRECTの実行結果

TestRECT
※ RECT は Left型

<元>
Left  : 1
Right : 3
Top   : 2
Bottom: 4

Width : 2
Height: 2

ShortSide : 2
LongSide  : 2

CenterPoint : 2 , 3

---
<a>
Left  : 1
Right : 3
Top   : 2
Bottom: 4

Width : 2
Height: 2

ShortSide : 2
LongSide  : 2

CenterPoint : 2 , 3

---
<b>
Left  : 5
Right : 70
Top   : 6
Bottom: 80

Width : 65
Height: 74

ShortSide : 65
LongSide  : 74

CenterPoint : 37.5 , 43

---
<c>
Left  : 9
Right : 110
Top   : 10
Bottom: 120

Width : 101
Height: 110

ShortSide : 101
LongSide  : 110

CenterPoint : 59.5 , 65

---
<d>
Left  : 13
Right : 150
Top   : 14
Bottom: 160

Width : 137
Height: 146

ShortSide : 137
LongSide  : 146

CenterPoint : 81.5 , 87

---
<a> .RectValue に RECT型変数を代入後
Left  : 10
Right : 30
Top   : 20
Bottom: 40

Width : 20
Height: 20

ShortSide : 20
LongSide  : 20

CenterPoint : 20 , 30

---
<a> 各プロパティ（.Left, .Top, .Right, .Bottom）個別設定後
Left  : 100
Right : 300
Top   : 200
Bottom: 400

Width : 200
Height: 200

ShortSide : 200
LongSide  : 200

CenterPoint : 200 , 300


X1: 100
X2: 300
Y1: 200
Y2: 400
---
<RECT型変数> ※ Rectangle オブジェクトから RECT 型変数へダイレクトに代入した結果
Left:   100
Right:  300
Top:    200
Bottom: 400