Skip to content

Commit d7d5eaa

Browse files
tothzolatothzola
committed
rubberduck-vba#12 Bound Layout
Layout bound at runtime. Implemented after the example from codereview. https://codereview.stackexchange.com/questions/58349/honey-i-shrunk-the-view
1 parent 02a486f commit d7d5eaa

File tree

5 files changed

+397
-0
lines changed

5 files changed

+397
-0
lines changed

‎src/ControlLayout.cls‎

Lines changed: 122 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,122 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
END
5+
Attribute VB_Name = "ControlLayout"
6+
Attribute VB_GlobalNameSpace = False
7+
Attribute VB_Creatable = False
8+
Attribute VB_PredeclaredId = False
9+
Attribute VB_Exposed = True
10+
Attribute VB_Description = "Encapsulates basic layout logic for dynamic MSForms controls."
11+
'@Folder MVVM.Infrastructure.View.Dynamic.Layout
12+
'@ModuleDescription "Encapsulates basic layout logic for dynamic MSForms controls."
13+
'@Exposed
14+
Option Explicit
15+
16+
Public Enum AnchorEdges
17+
LeftAnchor = 1
18+
TopAnchor = 2
19+
RightAnchor = 4
20+
BottomAnchor = 8
21+
AnchorAll = LeftAnchor + TopAnchor + RightAnchor + BottomAnchor
22+
End Enum
23+
24+
Private Type TControlLayout
25+
Anchors As AnchorEdges
26+
Margins As SideMargins
27+
ContainerSize As ControlSize
28+
ContainerItemSize As ControlSize
29+
BoundControl As MSForms.Control
30+
End Type
31+
32+
Private Const DefaultMargin As Long = 3
33+
34+
Private This As TControlLayout
35+
36+
Private Sub Layout(ByVal Object As MSForms.Control)
37+
38+
If (Anchors And TopAnchor) = TopAnchor Then
39+
40+
If (Anchors And BottomAnchor) = BottomAnchor Then
41+
Object.Height = This.ContainerSize.Height - Object.Top - This.Margins.BottomMargin
42+
End If
43+
44+
ElseIf (Anchors And BottomAnchor) = BottomAnchor Then
45+
Object.Top = This.ContainerSize.Height - Object.Height - This.Margins.BottomMargin
46+
End If
47+
48+
49+
If (Anchors And LeftAnchor) = LeftAnchor Then
50+
51+
If (Anchors And RightAnchor) = RightAnchor Then
52+
Object.Width = This.ContainerSize.Width - Object.Left - This.Margins.RightMargin
53+
End If
54+
55+
ElseIf (Anchors And RightAnchor) = RightAnchor Then
56+
Object.Left = This.ContainerSize.Width - Object.Width - This.Margins.RightMargin
57+
58+
End If
59+
60+
End Sub
61+
62+
Public Sub Bind(ByVal Container As Object, ByVal ContainerItem As MSForms.Control, ByVal Anchor As AnchorEdges)
63+
GuardClauses.GuardNullReference Container
64+
GuardClauses.GuardNullReference ContainerItem
65+
66+
Set This.ContainerSize = New ControlSize
67+
Set This.ContainerItemSize = New ControlSize
68+
Set This.Margins = New SideMargins
69+
This.Anchors = Anchor
70+
71+
This.ContainerSize.Height = Container.InsideHeight
72+
This.ContainerSize.Width = Container.InsideWidth
73+
74+
This.ContainerItemSize.Height = ContainerItem.Height
75+
This.ContainerItemSize.Width = ContainerItem.Width
76+
77+
If (Anchor And BottomAnchor) = BottomAnchor Then
78+
This.Margins.BottomMargin = This.ContainerSize.Height - ContainerItem.Top - ContainerItem.Height
79+
End If
80+
81+
If (Anchor And LeftAnchor) = LeftAnchor Then
82+
This.Margins.LeftMargin = ContainerItem.Left
83+
End If
84+
85+
If (Anchor And RightAnchor) = RightAnchor Then
86+
This.Margins.RightMargin = This.ContainerSize.Width - ContainerItem.Left - ContainerItem.Width
87+
End If
88+
89+
If (Anchor And TopAnchor) = TopAnchor Then
90+
This.Margins.TopMargin = ContainerItem.Top
91+
End If
92+
Set BoundControl = ContainerItem
93+
94+
End Sub
95+
96+
Public Sub Resize(ByVal Object As Object)
97+
This.ContainerSize.Height = Object.InsideHeight
98+
This.ContainerSize.Width = Object.InsideWidth
99+
Layout BoundControl
100+
End Sub
101+
102+
Private Sub Class_Terminate()
103+
Set This.ContainerSize = Nothing
104+
Set This.ContainerItemSize = Nothing
105+
End Sub
106+
107+
Public Property Get Anchors() As AnchorEdges
108+
Anchors = This.Anchors
109+
End Property
110+
111+
Public Property Let Anchors(ByVal RHS As AnchorEdges)
112+
This.Anchors = RHS
113+
End Property
114+
115+
Public Property Get BoundControl() As MSForms.Control
116+
Set BoundControl = This.BoundControl
117+
End Property
118+
119+
Public Property Set BoundControl(ByVal RHS As MSForms.Control)
120+
Set This.BoundControl = RHS
121+
End Property
122+

‎src/ControlSize.cls‎

Lines changed: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,35 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
END
5+
Attribute VB_Name = "ControlSize"
6+
Attribute VB_GlobalNameSpace = False
7+
Attribute VB_Creatable = False
8+
Attribute VB_PredeclaredId = False
9+
Attribute VB_Exposed = False
10+
'@Folder MVVM.Infrastructure.View.Dynamic.Layout
11+
Option Explicit
12+
13+
Private Type TControlSize
14+
Height As Single
15+
Width As Single
16+
End Type
17+
18+
Private This As TControlSize
19+
20+
Public Property Get Height() As Single
21+
Height = This.Height
22+
End Property
23+
24+
Public Property Let Height(ByVal RHS As Single)
25+
This.Height = RHS
26+
End Property
27+
28+
Public Property Get Width() As Single
29+
Width = This.Width
30+
End Property
31+
32+
Public Property Let Width(ByVal RHS As Single)
33+
This.Width = RHS
34+
End Property
35+

‎src/ILayout.cls‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
END
5+
Attribute VB_Name = "ILayout"
6+
Attribute VB_GlobalNameSpace = False
7+
Attribute VB_Creatable = False
8+
Attribute VB_PredeclaredId = False
9+
Attribute VB_Exposed = True
10+
Option Explicit
11+
12+
'@Folder MVVM.Infrastructure.View.Dynamic.Layout
13+
'@Exposed
14+
'@Interface
15+
16+
Public Sub BindControlLayout(ByVal Parent As Object, ByVal Child As MSForms.Control, ByVal Anchor As AnchorEdges)
17+
End Sub
18+
19+
Public Sub ResizeLayout()
20+
End Sub

‎src/Layout.cls‎

Lines changed: 168 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,168 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
END
5+
Attribute VB_Name = "Layout"
6+
Attribute VB_GlobalNameSpace = False
7+
Attribute VB_Creatable = False
8+
Attribute VB_PredeclaredId = True
9+
Attribute VB_Exposed = True
10+
Attribute VB_Description = "An object that encapsulates the UserForm Resizer"
11+
Attribute VB_Ext_KEY = "Rubberduck" ,"Predeclared Class Module"
12+
'@ModuleAttribute VB_Ext_KEY, "Rubberduck", "Predeclared Class Module"
13+
'@ModuleDescription "An object that encapsulates the UserForm Layout"
14+
'@Folder MVVM.Infrastructure.View.Dynamic.Layout
15+
'@PredeclaredId
16+
'@Exposed
17+
Option Explicit
18+
19+
Implements ILayout
20+
21+
#If VBA7 Then
22+
Private Declare PtrSafe Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
23+
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
24+
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
25+
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As LongPtr) As Long
26+
#Else
27+
Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
28+
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
29+
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
30+
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
31+
#End If
32+
33+
Private Const SM_CXSCREEN As Long = 0 'Horizontal Resolution
34+
Private Const SM_CYSCREEN As Long = 1 'Vertical Resolution
35+
Private Const LOGPIXELSX As Long = 88 'Pixels/inch in X
36+
Private Const POINTS_PER_INCH As Long = 72 'A point is defined as 1/72 inches
37+
Private Const DEFAULTWIDTH As Long = 240
38+
Private Const DEFAULTHEIGHT As Long = 180
39+
40+
41+
Private Type TState
42+
TotalMonitors As Long
43+
HorizontalResInPixel As Long
44+
VerticalResInPixel As Long
45+
46+
Object As Object
47+
Width As Single
48+
Height As Single
49+
LayoutBindings As Collection
50+
51+
End Type
52+
53+
Private This As TState
54+
55+
Public Property Get HorizontalResInPixel() As Long
56+
HorizontalResInPixel = GetSystemMetrics32(SM_CXSCREEN) * PointsPerPixel
57+
End Property
58+
59+
Public Property Get VerticalResInPixel() As Long
60+
VerticalResInPixel = GetSystemMetrics32(SM_CYSCREEN) * PointsPerPixel
61+
End Property
62+
63+
Public Property Get Object() As Object
64+
Set Object = This.Object
65+
End Property
66+
67+
Public Property Set Object(ByVal RHS As Object)
68+
Set This.Object = RHS
69+
End Property
70+
71+
Public Property Get Width() As Single
72+
Width = This.Object.Width
73+
End Property
74+
75+
Public Property Let Width(ByVal RHS As Single)
76+
GuardClauses.GuardExpression Throw:=Sgn(RHS - 0) + Sgn(RHS - 100), Message:="Value not between 0-100"
77+
This.Width = HorizontalResInPixel * (RHS / 100)
78+
End Property
79+
80+
Public Property Get Height() As Single
81+
Height = This.Object.Height
82+
End Property
83+
84+
Public Property Let Height(ByVal RHS As Single)
85+
GuardClauses.GuardExpression Throw:=Sgn(RHS - 0) + Sgn(RHS - 100), Message:="Value not between 0-100"
86+
This.Height = VerticalResInPixel * (RHS / 100)
87+
End Property
88+
89+
Public Property Get LayoutBindings() As Collection
90+
Set LayoutBindings = This.LayoutBindings
91+
End Property
92+
93+
Public Property Set LayoutBindings(ByVal RHS As Collection)
94+
GuardClauses.GuardNullReference RHS
95+
Set This.LayoutBindings = RHS
96+
End Property
97+
98+
Public Function Create(ByVal Object As Object, Optional ByVal NewWidthPercent As Long = 50, Optional ByVal NewHeightPercent As Long = 50) As Layout
99+
GuardClauses.GuardNonDefaultInstance Me, Layout, TypeName(Me)
100+
GuardClauses.GuardNullReference Object, VBA.Information.TypeName(Me)
101+
102+
Dim result As Layout
103+
Set result = New Layout
104+
Set result.Object = Object
105+
result.Width = NewWidthPercent
106+
result.Height = NewHeightPercent
107+
Set result.LayoutBindings = New Collection
108+
Set Create = result
109+
110+
End Function
111+
112+
Public Sub BindControlLayout(ByVal Parent As Object, ByVal Child As MSForms.Control, ByVal Anchor As AnchorEdges)
113+
GuardClauses.GuardNullReference Parent
114+
GuardClauses.GuardNullReference Child
115+
116+
Dim Layout As ControlLayout
117+
Set Layout = New ControlLayout
118+
Layout.Bind Parent, Child, Anchor
119+
120+
This.LayoutBindings.Add Layout
121+
End Sub
122+
123+
Public Sub ResizeLayout()
124+
125+
If This.Width < Object.Width Then Object.Width = DEFAULTWIDTH Else Object.Width = This.Width
126+
If This.Height < Object.Height Then Object.Height = DEFAULTHEIGHT Else Object.Height = This.Height
127+
128+
On Error GoTo CleanFail
129+
Dim Layout As ControlLayout
130+
For Each Layout In This.LayoutBindings
131+
Layout.Resize Object
132+
Next
133+
134+
CleanExit:
135+
Exit Sub
136+
137+
CleanFail:
138+
MsgBox VBA.Err.Description, Title:=VBA.Err.Number
139+
Resume CleanExit
140+
Resume
141+
142+
End Sub
143+
144+
'@Description "Get Points Per Pixel Screen resloution."
145+
Private Function PointsPerPixel() As Double
146+
147+
#If VBA7 Then
148+
Dim HandleContex As LongPtr
149+
Dim DotsPerInch As LongPtr
150+
#Else
151+
Dim HandleContex As Long
152+
Dim DotsPerInch As Long
153+
#End If
154+
155+
HandleContex = GetDC(0)
156+
DotsPerInch = GetDeviceCaps(HandleContex, LOGPIXELSX)
157+
PointsPerPixel = POINTS_PER_INCH / DotsPerInch
158+
ReleaseDC 0, HandleContex
159+
160+
End Function
161+
162+
Private Sub ILayout_BindControlLayout(ByVal Parent As Object, ByVal Child As MSForms.Control, ByVal Anchor As AnchorEdges)
163+
BindControlLayout Parent, Child, Anchor
164+
End Sub
165+
166+
Private Sub ILayout_ResizeLayout()
167+
ResizeLayout
168+
End Sub

0 commit comments

Comments
 (0)