This sample project shows how you can automatically resize your form and its controls as well as adjust their font sizes whenever the current DPI changes (the user runs their desktop at a different DPI, or changes the DPI on a whim or maybe drags your window to another monitor with a different DPI).
The main prerequisite is that your app is manifested for "PerMonitorV2":
A sample manifest is included in the project for this purpose. Now the system will send the WM_DPICHANGED message whenever the current DPI changes (this includes the first time your app is executed on a system with non-standard DPI (other than 96), as well as subsequent changes in real time).
The demo project below includes a form and some of the most frequently encountered controls (CommandButton, Frame, OptionButton, CheckBox, Label, TextBox, Image, HScrollBar, ComboBox) but the concept remains the same for any other controls you might use:
DPI Awareness Test - 100% Scaling:
![Name: DPITest100%.png
Views: 51
Size: 74.2 KB]()
DPI Awareness Test - 125% Scaling:
![Name: DPITest125%.png
Views: 51
Size: 110.8 KB]()
DPI Awareness Test - 150% Scaling:
![Name: DPITest150%.png
Views: 52
Size: 140.2 KB]()
DPI Awareness Test - 175% Scaling:
![Name: DPITest175%.png
Views: 51
Size: 148.2 KB]()
I only have a couple of Full HD monitors (1920x1080) so I could only test 100%, 125%, 150% and 175% scaling modes. I would be interested to see if the scaling works just as well on 2k and 4k monitors if someone else could test it.
The concept is fairly simple, just subclass your form and intercept the "WM_DPICHANGED" message which will kindly provide you with the new scaling factor and window size for your form. From there all it takes is to resize the rest of your controls and their font sizes with the new scaling factor:
frmDPITest
mdlSubclass - This module demonstrates the original subclassing method (changing a window's procedure with SetWindowLong) but you can easily replace it with the newer "comctl32" subclassing method (using the "SetWindowSubclass" API). I just wanted to see if I could use "SetWindowLong" to mimic the same behavior (as an exercise):
ISubclass
Here is the demo project: DPITest.zip
The main prerequisite is that your app is manifested for "PerMonitorV2":
Code:
<dpiAwareness xmlns="http://schemas.microsoft.com/SMI/2016/WindowsSettings">PerMonitorV2</dpiAwareness>The demo project below includes a form and some of the most frequently encountered controls (CommandButton, Frame, OptionButton, CheckBox, Label, TextBox, Image, HScrollBar, ComboBox) but the concept remains the same for any other controls you might use:
DPI Awareness Test - 100% Scaling:
DPI Awareness Test - 125% Scaling:
DPI Awareness Test - 150% Scaling:
DPI Awareness Test - 175% Scaling:
I only have a couple of Full HD monitors (1920x1080) so I could only test 100%, 125%, 150% and 175% scaling modes. I would be interested to see if the scaling works just as well on 2k and 4k monitors if someone else could test it.
The concept is fairly simple, just subclass your form and intercept the "WM_DPICHANGED" message which will kindly provide you with the new scaling factor and window size for your form. From there all it takes is to resize the rest of your controls and their font sizes with the new scaling factor:
frmDPITest
Code:
Option Explicit
Implements ISubclass
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const WM_DPICHANGED As Long = &H2E0, LOGPIXELSX As Long = 88, SWP_NOACTIVATE As Long = &H10, SWP_NOOWNERZORDER As Long = &H200, SWP_NOZORDER As Long = &H4
Private m_lOrigWndProc As Long, lInitialDPI As Long, sngScaleFactor As Single
Private Sub cmdAnotherCommandButton_Click()
Unload Me
End Sub
Private Sub Form_Load()
cmbComboBox.AddItem TypeName(cmbComboBox): cmbComboBox.ListIndex = 0
lInitialDPI = GetDeviceCaps(hDC, LOGPIXELSX): sngScaleFactor = lInitialDPI / 96 ' Calculate the initial DPI and ScaleFactor values
SubclassWnd hWnd, Me ' Subclass the form to check for DPI changes
End Sub
Private Sub ResizeControls()
Dim xControl As Control
If sngScaleFactor <> 1 Then ' Resize controls only when the ScaleFactor has changed
For Each xControl In Controls
With xControl
Select Case True
Case TypeOf xControl Is CommandButton, TypeOf xControl Is Frame, TypeOf xControl Is OptionButton, TypeOf xControl Is CheckBox, TypeOf xControl Is Label, TypeOf xControl Is TextBox
.Left = .Left * sngScaleFactor: .Top = .Top * sngScaleFactor: .Width = .Width * sngScaleFactor
.Font.Size = .Font.Size * sngScaleFactor: .Height = .Height * sngScaleFactor
Case TypeOf xControl Is ComboBox ' Height is ReadOnly for a ComboBox
.Left = .Left * sngScaleFactor: .Top = .Top * sngScaleFactor: .Width = .Width * sngScaleFactor: .Font.Size = .Font.Size * sngScaleFactor
Case TypeOf xControl Is HScrollBar, TypeOf xControl Is Image ' These controls don't have a Font property
.Left = .Left * sngScaleFactor: .Top = .Top * sngScaleFactor: .Width = .Width * sngScaleFactor: .Height = .Height * sngScaleFactor
End Select
End With
Next xControl
End If
End Sub
Private Property Get ISubclass_OrigWndProc() As Long
ISubclass_OrigWndProc = m_lOrigWndProc
End Property
Private Property Let ISubclass_OrigWndProc(lOrigWndProc As Long)
m_lOrigWndProc = lOrigWndProc
End Property
Private Function ISubclass_WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Static lNewDPI As Long
Dim bDiscardMessage As Boolean
Select Case uMsg
Case WM_DPICHANGED ' This message signals a change in the DPI of the current monitor or the window was dragged to a monitor with a different DPI
Dim rcWndRect As RECT, lOldDPI As Long
If lNewDPI Then lOldDPI = lNewDPI Else lOldDPI = lInitialDPI
lNewDPI = wParam And &HFFFF&: sngScaleFactor = lNewDPI / lOldDPI ' Calculate the new DPI value and ScaleFactor
CopyMemory ByVal VarPtr(rcWndRect), ByVal lParam, LenB(rcWndRect) ' The new suggested window size is saved in a RECT structure pointed by lParam
With rcWndRect
SetWindowPos hWnd, 0, .Left, .Top, .Right - .Left, .Bottom - .Top, SWP_NOACTIVATE Or SWP_NOOWNERZORDER Or SWP_NOZORDER ' Resize the form to reflect the new DPI changes
End With
ResizeControls ' After the form is resized do the same for all its controls
End Select
If Not bDiscardMessage Then ISubclass_WndProc = CallWindowProc(m_lOrigWndProc, hWnd, uMsg, wParam, lParam)
End FunctionCode:
Option Explicit
Private Const GWL_WNDPROC As Long = (-4), GWL_USERDATA As Long = (-21), WM_NCDESTROY As Long = &H82
Private Declare Function vbaObjSetAddref Lib "msvbvm60" Alias "__vbaObjSetAddref" (dstObject As Any, ByVal lpObject As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Function SubclassWnd(hWnd As Long, Subclass As ISubclass) As Boolean
With Subclass
If .OrigWndProc = 0 Then
.OrigWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WndProc) ' Save the original Window Procedure and then subclass it
SetWindowLong hWnd, GWL_USERDATA, ObjPtr(Subclass): SubclassWnd = True ' Save a reference to our subclassed object
End If
End With
End Function
Private Function UnSubclassWnd(hWnd As Long, Subclass As ISubclass) As Boolean
With Subclass
If .OrigWndProc Then SetWindowLong hWnd, GWL_WNDPROC, .OrigWndProc: UnSubclassWnd = True ' Remove the subclass and restore the original Window Procedure
End With
End Function
Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim Subclass As ISubclass
vbaObjSetAddref Subclass, GetWindowLong(hWnd, GWL_USERDATA) ' Return an object from a pointer (inverse of ObjPtr). This is our subclassed object whose reference we saved above
Select Case uMsg
Case WM_NCDESTROY ' Remove subclassing as the window is about to be destroyed
UnSubclassWnd hWnd, Subclass
CallWindowProc Subclass.OrigWndProc, hWnd, uMsg, wParam, lParam
Case Else
WndProc = Subclass.WndProc(hWnd, uMsg, wParam, lParam) ' Pass all messages to our custom subclassed procedure
End Select
End FunctionCode:
Option Explicit
Public Property Get OrigWndProc() As Long
End Property
Public Property Let OrigWndProc(lOrigWndProc As Long)
End Property
Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
End Function