From d7d5eaad8e3ed4e185b7547460b68b81424d3ea9 Mon Sep 17 00:00:00 2001 From: Toth Zoltan Date: Fri, 5 Nov 2021 16:54:00 +0200 Subject: [PATCH] #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 | 122 ++++++++++++++++++++++++++++++ src/ControlSize.cls | 35 +++++++++ src/ILayout.cls | 20 +++++ src/Layout.cls | 168 ++++++++++++++++++++++++++++++++++++++++++ src/SideMargins.cls | 52 +++++++++++++ 5 files changed, 397 insertions(+) create mode 100644 src/ControlLayout.cls create mode 100644 src/ControlSize.cls create mode 100644 src/ILayout.cls create mode 100644 src/Layout.cls create mode 100644 src/SideMargins.cls diff --git a/src/ControlLayout.cls b/src/ControlLayout.cls new file mode 100644 index 0000000..9d80b5f --- /dev/null +++ b/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 + diff --git a/src/ControlSize.cls b/src/ControlSize.cls new file mode 100644 index 0000000..876bd2f --- /dev/null +++ b/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 + diff --git a/src/ILayout.cls b/src/ILayout.cls new file mode 100644 index 0000000..7841d03 --- /dev/null +++ b/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 diff --git a/src/Layout.cls b/src/Layout.cls new file mode 100644 index 0000000..536ebb2 --- /dev/null +++ b/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 diff --git a/src/SideMargins.cls b/src/SideMargins.cls new file mode 100644 index 0000000..de85bd2 --- /dev/null +++ b/src/SideMargins.cls @@ -0,0 +1,52 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "SideMargins" +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 TSideMargins + BottomMargin As Double + LeftMargin As Double + RightMargin As Double + TopMargin As Double +End Type + +Private This As TSideMargins + +Public Property Get BottomMargin() As Double + BottomMargin = This.BottomMargin +End Property + +Public Property Let BottomMargin(ByVal RHS As Double) + This.BottomMargin = RHS +End Property + +Public Property Get LeftMargin() As Double + LeftMargin = This.LeftMargin +End Property + +Public Property Let LeftMargin(ByVal RHS As Double) + This.LeftMargin = RHS +End Property + +Public Property Get RightMargin() As Double + RightMargin = This.RightMargin +End Property + +Public Property Let RightMargin(ByVal RHS As Double) + This.RightMargin = RHS +End Property + +Public Property Get TopMargin() As Double + TopMargin = This.TopMargin +End Property + +Public Property Let TopMargin(ByVal RHS As Double) + This.TopMargin = RHS +End Property