VBA Access. Módulo de clase clsResizeForm. Redimensionar formulario. Resize form.

Option Compare Database
Option Explicit

'CREDITS:
'This modResizeForm module was created by Jamie Czernik 31st March 2000 (jsczernik@hotmail.com)
'The module was updated by Dr. Martin Dumskyj 30th January 2001 (mdumskyj@sghms.ac.UK)
'Module Declarations (here, set the original resolution width was made the form)

'* changes to use as a class and now can pass the resolutionX as an argument
'* To use, put on event onload form passing form and DesignResolutionX as argument  : create object and then ... objResizeForm.ResizeForm Me, 1024
'* Added control for 64 bits Windows API declaration
'* Tip: DesignResolutionX nomally must be the resolutionX that was designed the form to adjust to the current resolution

Const WM_HORZRES = 8
Const WM_VERTRES = 10

Dim m_DesignResolutionX As Integer

Dim Width As Integer
Dim Factor As Single 'Used as multiplier for current size properties'

'Windows API Function Declarations
#If Win64 = 1 Then
    Private Declare PtrSafe Function WM_apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function WM_apiGetDesktopWindow Lib "user32" Alias "GetDesktopWindow" () As Long
    Private Declare PtrSafe Function WM_apiGetDC Lib "user32" Alias "GetDC" (ByVal hWnd As Long) As Long
    Private Declare PtrSafe Function WM_apiReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal hWnd As Long, ByVal hDC As Long) As Long
    Private Declare PtrSafe Function WM_apiGetSystemMetrics Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
#Else
    Private Declare Function WM_apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare Function WM_apiGetDesktopWindow Lib "user32" Alias "GetDesktopWindow" () As Long
    Private Declare Function WM_apiGetDC Lib "user32" Alias "GetDC" (ByVal hWnd As Long) As Long
    Private Declare Function WM_apiReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal hWnd As Long, ByVal hDC As Long) As Long
    Private Declare Function WM_apiGetSystemMetrics Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
#End If

Function GetScreenResolution() As String
    'returns the height and width
    Dim DisplayHeight As Integer
    Dim DisplayWidth As Integer
    Dim hDesktopWnd As Long
    Dim hDCcaps As Long
    Dim iRtn As Integer
    'API call get current resolution
    hDesktopWnd = WM_apiGetDesktopWindow() 'get handle to desktop
    hDCcaps = WM_apiGetDC(hDesktopWnd) 'get display context for desktop
    DisplayHeight = WM_apiGetDeviceCaps(hDCcaps, WM_VERTRES)
    DisplayWidth = WM_apiGetDeviceCaps(hDCcaps, WM_HORZRES)
    iRtn = WM_apiReleaseDC(hDesktopWnd, hDCcaps) 'release display context
    GetScreenResolution = DisplayWidth & "x" & DisplayHeight
    Width = DisplayWidth
End Function

Public Sub ReSizeForm(frm As Form, Optional ByVal DesignResolutionX As Integer = 1024)
On Error Resume Next
    Dim ctl As Control
 
    m_DesignResolutionX = DesignResolutionX
    SetFactor 'Call to procedure SetFactor
 
    With frm
        .Width = frm.Width * Factor
    End With
 
    For Each ctl In frm.Controls
        With ctl
            .Height = ctl.Height * Factor
            .Left = ctl.Left * Factor
            .Top = ctl.Top * Factor
            .Width = ctl.Width * Factor
            .FontSize = .FontSize * Factor
        End With
    Next ctl
End Sub

Sub SetFactor()
    GetScreenResolution 'Call to function GetScreenResolution
    Factor = Width / m_DesignResolutionX
End Sub