Skip to content

Instantly share code, notes, and snippets.

@furyutei

furyutei/0.README.md

Last active Aug 7, 2020
Embed
What would you like to do?
[Excel][VBA] RECT型(ユーザー定義型)変数とクラスモジュール間で値をダイレクトにやり取りする試み

[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

元ネタ

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
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
@furyutei

This comment has been minimized.

Copy link
Owner Author

@furyutei furyutei commented Jul 22, 2020

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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.