Not exactly sure if this will fix your userform placement problem and I also suspect that you will need to re-size your userform and controls but this code might help. The API's will provide you the screen resolution and scale factor being used. The code also adjusts the XL zoom based on the scale factor which MAY solve your placement problem. It does nothing to adjust your userform and controls size(s). Also, I found a couple of the new API's which I included that can also be used to provide the scale (which for some reason is slightly different than the previous method?). The wb needs to be opened after changes to the screen appearance so it seems using a wb open event is best to run the code. HTH. Dave
workbook code...
Private Sub Workbook_Open()
Call ScreenInfo
End Sub
Module code...
#If VBA7 And Win64 Then
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Public Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Dim hdcScreen As LongPtr
#Else
Dim hdcScreen As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Public Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
#End If
Public Declare PtrSafe Function GetDpiForWindow Lib "user32" (ByVal hWnd As Long) As Long
Public Declare PtrSafe Function GetSystemMetricsForDpi Lib "user32" (ByVal nIdx As Long, ByVal lDPI As Long) As Long
Public Const LOGPIXELSX = 88 'Pixels/inch in X
Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
Public X As Long
Public Y As Long
Public Function GetDpi() As Long
Dim iDPI As Long
iDPI = -1
hdcScreen = GetDC(0)
If (hdcScreen) Then
iDPI = GetDeviceCaps(hdcScreen, LOGPIXELSX)
ReleaseDC 0, hdcScreen
End If
GetDpi = iDPI
End Function
Sub ScreenInfo()
Dim DPIScale As Double, DPIScale2 As Double
X = GetSystemMetrics(SM_CXSCREEN)
Y = GetSystemMetrics(SM_CYSCREEN)
DPIScale = GetDpi
If DPIScale <> 96 Then
DPIScale = (1 + ((DPIScale - 96) / 96)) * 100
Else
DPIScale = 100
End If
MsgBox "Screen Resolution: " & X & " x " & Y & vbCrLf _
& "Scale: " & DPIScale & "%"
Call ScreenResToZoom(DPIScale)
'trial GetSystemMetricsForDpi
'DPIScale2 = GetSystemMetricsForDpi(2, GetDpi)
'If DPIScale2 <> 17 Then
'DPIScale2 = (1 + ((DPIScale2 - 17) / 17)) * 100
'Else
'DPIScale2 = 100
'End If
'MsgBox "DPIScale using GetSystemMetricsForDpi: " & DPIScale2 & "%"
End Sub
Public Function ScreenResToZoom(DPIScaler As Double)
Select Case DPIScaler
Case Is = 100
ScreenResToZoom = 100
Case Is = 125
ScreenResToZoom = 95
Case Is = 150
ScreenResToZoom = 85
Case Is = 175
ScreenResToZoom = 70
Case Else
ScreenResToZoom = 50
End Select
ActiveWindow.Zoom = ScreenResToZoom
End Function