VB6 - Simple way to make your VB6 application "Per-Monitor DPI Aware"

[VanGoghGaming]

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":

<dpiAwareness xmlns="http://schemas.microsoft.com/SMI/2016/WindowsSettings">PerMonitorV2</dpiAwareness>

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:



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

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 Function

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):

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 Function

ISubclass

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

Here is the demo project: DPITest.zip