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

src/ControlLayout.cls

@@ -0,0 +1,122 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ControlLayout"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = True
+Attribute VB_Description = "Encapsulates basic layout logic for dynamic MSForms controls."
+'@Folder MVVM.Infrastructure.View.Dynamic.Layout
+'@ModuleDescription "Encapsulates basic layout logic for dynamic MSForms controls."
+'@Exposed
+Option Explicit
+
+Public Enum AnchorEdges
+    LeftAnchor = 1
+    TopAnchor = 2
+    RightAnchor = 4
+    BottomAnchor = 8
+    AnchorAll = LeftAnchor + TopAnchor + RightAnchor + BottomAnchor
+End Enum
+
+Private Type TControlLayout
+    Anchors As AnchorEdges
+    Margins As SideMargins
+    ContainerSize As ControlSize
+    ContainerItemSize As ControlSize
+    BoundControl As MSForms.Control
+End Type
+
+Private Const DefaultMargin As Long = 3
+
+Private This As TControlLayout
+
+Private Sub Layout(ByVal Object As MSForms.Control)
+
+    If (Anchors And TopAnchor) = TopAnchor Then
+
+        If (Anchors And BottomAnchor) = BottomAnchor Then
+            Object.Height = This.ContainerSize.Height - Object.Top - This.Margins.BottomMargin
+        End If
+
+    ElseIf (Anchors And BottomAnchor) = BottomAnchor Then
+        Object.Top = This.ContainerSize.Height - Object.Height - This.Margins.BottomMargin
+    End If
+
+
+    If (Anchors And LeftAnchor) = LeftAnchor Then
+
+        If (Anchors And RightAnchor) = RightAnchor Then
+            Object.Width = This.ContainerSize.Width - Object.Left - This.Margins.RightMargin
+        End If
+
+    ElseIf (Anchors And RightAnchor) = RightAnchor Then
+        Object.Left = This.ContainerSize.Width - Object.Width - This.Margins.RightMargin
+
+    End If
+
+End Sub
+
+Public Sub Bind(ByVal Container As Object, ByVal ContainerItem As MSForms.Control, ByVal Anchor As AnchorEdges)
+    GuardClauses.GuardNullReference Container
+    GuardClauses.GuardNullReference ContainerItem
+
+    Set This.ContainerSize = New ControlSize
+    Set This.ContainerItemSize = New ControlSize
+    Set This.Margins = New SideMargins
+    This.Anchors = Anchor
+
+    This.ContainerSize.Height = Container.InsideHeight
+    This.ContainerSize.Width = Container.InsideWidth
+
+    This.ContainerItemSize.Height = ContainerItem.Height
+    This.ContainerItemSize.Width = ContainerItem.Width
+
+    If (Anchor And BottomAnchor) = BottomAnchor Then
+        This.Margins.BottomMargin = This.ContainerSize.Height - ContainerItem.Top - ContainerItem.Height
+    End If
+
+    If (Anchor And LeftAnchor) = LeftAnchor Then
+        This.Margins.LeftMargin = ContainerItem.Left
+    End If
+
+    If (Anchor And RightAnchor) = RightAnchor Then
+        This.Margins.RightMargin = This.ContainerSize.Width - ContainerItem.Left - ContainerItem.Width
+    End If
+
+    If (Anchor And TopAnchor) = TopAnchor Then
+        This.Margins.TopMargin = ContainerItem.Top
+    End If
+    Set BoundControl = ContainerItem
+
+End Sub
+
+Public Sub Resize(ByVal Object As Object)
+    This.ContainerSize.Height = Object.InsideHeight
+    This.ContainerSize.Width = Object.InsideWidth
+    Layout BoundControl
+End Sub
+
+Private Sub Class_Terminate()
+    Set This.ContainerSize = Nothing
+    Set This.ContainerItemSize = Nothing
+End Sub
+
+Public Property Get Anchors() As AnchorEdges
+    Anchors = This.Anchors
+End Property
+
+Public Property Let Anchors(ByVal RHS As AnchorEdges)
+    This.Anchors = RHS
+End Property
+
+Public Property Get BoundControl() As MSForms.Control
+    Set BoundControl = This.BoundControl
+End Property
+
+Public Property Set BoundControl(ByVal RHS As MSForms.Control)
+    Set This.BoundControl = RHS
+End Property
+

src/ControlSize.cls

@@ -0,0 +1,35 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ControlSize"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+'@Folder MVVM.Infrastructure.View.Dynamic.Layout
+Option Explicit
+
+Private Type TControlSize
+    Height As Single
+    Width As Single
+End Type
+
+Private This As TControlSize
+
+Public Property Get Height() As Single
+    Height = This.Height
+End Property
+
+Public Property Let Height(ByVal RHS As Single)
+    This.Height = RHS
+End Property
+
+Public Property Get Width() As Single
+    Width = This.Width
+End Property
+
+Public Property Let Width(ByVal RHS As Single)
+    This.Width = RHS
+End Property
+

src/ILayout.cls

@@ -0,0 +1,20 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ILayout"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = True
+Option Explicit
+
+'@Folder MVVM.Infrastructure.View.Dynamic.Layout
+'@Exposed
+'@Interface
+
+Public Sub BindControlLayout(ByVal Parent As Object, ByVal Child As MSForms.Control, ByVal Anchor As AnchorEdges)
+End Sub
+
+Public Sub ResizeLayout()
+End Sub

src/Layout.cls

@@ -0,0 +1,168 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "Layout"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Attribute VB_Description = "An object that encapsulates the UserForm Resizer"
+Attribute VB_Ext_KEY = "Rubberduck" ,"Predeclared Class Module"
+'@ModuleAttribute VB_Ext_KEY, "Rubberduck", "Predeclared Class Module"
+'@ModuleDescription "An object that encapsulates the UserForm Layout"
+'@Folder MVVM.Infrastructure.View.Dynamic.Layout
+'@PredeclaredId
+'@Exposed
+Option Explicit
+
+Implements ILayout
+
+#If VBA7 Then
+    Private Declare PtrSafe Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
+    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
+    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As LongPtr) As Long
+#Else
+    Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
+    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
+    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
+#End If
+
+Private Const SM_CXSCREEN As Long = 0               'Horizontal Resolution
+Private Const SM_CYSCREEN As Long = 1               'Vertical Resolution
+Private Const LOGPIXELSX As Long = 88               'Pixels/inch in X
+Private Const POINTS_PER_INCH As Long = 72          'A point is defined as 1/72 inches
+Private Const DEFAULTWIDTH As Long = 240
+Private Const DEFAULTHEIGHT As Long = 180
+
+
+Private Type TState
+    TotalMonitors As Long
+    HorizontalResInPixel As Long
+    VerticalResInPixel As Long
+
+    Object As Object
+    Width As Single
+    Height As Single
+    LayoutBindings As Collection
+
+End Type
+
+Private This As TState
+
+Public Property Get HorizontalResInPixel() As Long
+    HorizontalResInPixel = GetSystemMetrics32(SM_CXSCREEN) * PointsPerPixel
+End Property
+
+Public Property Get VerticalResInPixel() As Long
+    VerticalResInPixel = GetSystemMetrics32(SM_CYSCREEN) * PointsPerPixel
+End Property
+
+Public Property Get Object() As Object
+    Set Object = This.Object
+End Property
+
+Public Property Set Object(ByVal RHS As Object)
+    Set This.Object = RHS
+End Property
+
+Public Property Get Width() As Single
+    Width = This.Object.Width
+End Property
+
+Public Property Let Width(ByVal RHS As Single)
+    GuardClauses.GuardExpression Throw:=Sgn(RHS - 0) + Sgn(RHS - 100), Message:="Value not between 0-100"
+    This.Width = HorizontalResInPixel * (RHS / 100)
+End Property
+
+Public Property Get Height() As Single
+    Height = This.Object.Height
+End Property
+
+Public Property Let Height(ByVal RHS As Single)
+    GuardClauses.GuardExpression Throw:=Sgn(RHS - 0) + Sgn(RHS - 100), Message:="Value not between 0-100"
+    This.Height = VerticalResInPixel * (RHS / 100)
+End Property
+
+Public Property Get LayoutBindings() As Collection
+    Set LayoutBindings = This.LayoutBindings
+End Property
+
+Public Property Set LayoutBindings(ByVal RHS As Collection)
+    GuardClauses.GuardNullReference RHS
+    Set This.LayoutBindings = RHS
+End Property
+
+Public Function Create(ByVal Object As Object, Optional ByVal NewWidthPercent As Long = 50, Optional ByVal NewHeightPercent As Long = 50) As Layout
+    GuardClauses.GuardNonDefaultInstance Me, Layout, TypeName(Me)
+    GuardClauses.GuardNullReference Object, VBA.Information.TypeName(Me)
+
+    Dim result As Layout
+    Set result = New Layout
+    Set result.Object = Object
+        result.Width = NewWidthPercent
+        result.Height = NewHeightPercent
+    Set result.LayoutBindings = New Collection
+    Set Create = result
+
+End Function
+
+Public Sub BindControlLayout(ByVal Parent As Object, ByVal Child As MSForms.Control, ByVal Anchor As AnchorEdges)
+    GuardClauses.GuardNullReference Parent
+    GuardClauses.GuardNullReference Child
+
+    Dim Layout As ControlLayout
+    Set Layout = New ControlLayout
+    Layout.Bind Parent, Child, Anchor
+
+    This.LayoutBindings.Add Layout
+End Sub
+
+Public Sub ResizeLayout()
+
+    If This.Width < Object.Width Then Object.Width = DEFAULTWIDTH Else Object.Width = This.Width
+    If This.Height < Object.Height Then Object.Height = DEFAULTHEIGHT Else Object.Height = This.Height
+
+    On Error GoTo CleanFail
+    Dim Layout As ControlLayout
+    For Each Layout In This.LayoutBindings
+        Layout.Resize Object
+    Next
+
+CleanExit:
+    Exit Sub
+
+CleanFail:
+    MsgBox VBA.Err.Description, Title:=VBA.Err.Number
+    Resume CleanExit
+    Resume
+
+End Sub
+
+'@Description "Get Points Per Pixel Screen resloution."
+Private Function PointsPerPixel() As Double
+
+    #If VBA7 Then
+        Dim HandleContex As LongPtr
+        Dim DotsPerInch As LongPtr
+    #Else
+        Dim HandleContex As Long
+        Dim DotsPerInch As Long
+    #End If
+
+    HandleContex = GetDC(0)
+    DotsPerInch = GetDeviceCaps(HandleContex, LOGPIXELSX)
+    PointsPerPixel = POINTS_PER_INCH / DotsPerInch
+    ReleaseDC 0, HandleContex
+
+End Function
+
+Private Sub ILayout_BindControlLayout(ByVal Parent As Object, ByVal Child As MSForms.Control, ByVal Anchor As AnchorEdges)
+    BindControlLayout Parent, Child, Anchor
+End Sub
+
+Private Sub ILayout_ResizeLayout()
+    ResizeLayout
+End Sub