Scale display vba code

[chubbychub]

I have different display Scale level, some monitors at 100%, other s at 200%, others at 175%, others at 300 %, and userform dont display when the userform is set on the bottom of the excel sheet, (the resolution on this screen are the same at 3840 x2160 on all the screens but not SCALE)
i dont want the userform to appear in the middle, if there was a code to obtain the SCALE level , then i can put a vba code to position the userform according to scale level with a IF and else statement to position the userform accordingly. If someone can help me to code in vba about obtaining windows 11 scale level with 64bit excel 2019 please.

P.D. I have google for a couple of days and all vba code that i have found is regarding screen resolution and pixels.

[SamT]

Start with SR and Pixels, convert them to Points(?) Top, Left, Height, and Width. Find Ratios and Adjust Form locations.

[arnelgp]

you can test this.
although i don't use scale.

[Aussiebear]

Given that 1 pixel = 0.75 points. 3840 x 2160 pixels is roughly 2880 x 1620 points

[chubbychub]

thank you all for the replies, however , how will the file on post 2 or the other suggestions be able to tell a resolution screen 3840 x2160 at scale 100% from a screen resolution of 3840 x2160 at a scale of 300% ? because it appears way off screen at 300%

[arnelgp]

after setting the scale to 300%, do you re-start Excel also?

[chubbychub]

these are different computers screen so all the monitors have the same resolution but not the scale so they always start at resolution 3840 x2160 at 100%, another screen 3840x2160 at 175%, anotehr screen at 3840x2160 at 300%, another screen at 3840x2160 at 475%

so i was testing to detect resolution screen and put a if and else statement, but dont work, since they are the same resolution, but the scale is different. so if there was a way to detect or differentiate the scale factor from windows 11.
i mean these computers are for different purposes for designs, but they all use the same userform for quoting price.

[Dave]

arnelgo seemed to have missed some code in the attached wb but did include a link to this..
https://forum.ozgrid.com/forum/index.php?thread/142634-vba-to-automatically-resize-user-form-depending-on-screen-resolution/
which works quite well and does adjust the forms for zoom (DPI). You may need to adjust the API's for 64bit use. Your next difficulty will be adjusting the controls on the form to resize and reposition with the change in the form size. HTH. Dave

[chubbychub]

no, the DPI is for printing, the screen all have the same resolution but the level of zoom is different and that needs to be detected, not the DPI. attached i have posted a picture at 100% scale with 3840 x2160 which is positioned exactly on where i want it. BUT, at another screen of 300% with resolution of 3840x2160..(same) but at a 300% scale, the Userform dont even appear on the screen (and cant see it so not clickable)

30475

[chubbychub]

I really think i am out of luck, i have been googling for weeks on finding a way to get scale level, and cant seem to find anything to get it from windows 11. or if someone can kindly point a finger on where to look around please, will appreciated and thank you for reading.

I mean to simplify things, but just not possible, i can adjust display all at standard zoom but some screen are on walls and far to see so hence on 8K monitors, its needs 400% zoom level to be view.

[arnelgp]

did you test the workbook i upload on all those pc (with diiferent zoom level).
in my opinion, it will work for whaever zoom level.
if Excel is displayed "normal" to all zoom level (on all pc's), then it should work
since it uses the Excel size (on current zoom level) to position the userform.

note, i never tried it on "shared" workbook.

[chubbychub]

yes i tried it, but didnt work at the 300%. Excel is not displayed normal, its only half of the top excel part is displayed, so when the userform apppears, it will be on the bottom (which is off screen).
so my idea was to put a if and else statement by detecting scale level somethihng like this:



if windows scale level is 300%, then userform position at middle screen
if windows scale level is 200% , then userform position at bottom of screen
if windows scale level at 100%, then appear on top of screen


obiously in vba language, but i havent figure that out yet

[arnelgp]

you check this forum for the scale:
DPI-related APIs and registry settings | Microsoft Learn (https://learn.microsoft.com/en-us/windows-hardware/manufacture/desktop/dpi-related-apis-and-registry-settings?view=windows-11)

the value in:

HKCU\Control Panel\Desktop\LogPixels

and using Code in:
Find registry key using Excel VBA - Stack Overflow (https://stackoverflow.com/questions/35936735/find-registry-key-using-excel-vba)



' https://stackoverflow.com/questions/35936735/find-registry-key-using-excel-vba
Private Sub test()
Dim key As String
Dim objShell As Object

Set objShell = CreateObject("WScript.Shell")
key = objShell.RegRead("HKCU\Control Panel\Desktop\LogPixels")
Debug.Print Val(key)
If Len(key) Then
Debug.Print "Scale: " & FormatPercent(Val(key) / 96, 0)
End If
End Sub

[Dave]

How to build high DPI aware native Windows desktop applications (mariusbancila.ro) (https://mariusbancila.ro/blog/2021/05/19/how-to-build-high-dpi-aware-native-desktop-applications/)
The link explains what the problem is and why previous DPI measurements always return 96.... the native DPI rather than the effective DPI created by scaling. After a certain version of Windows 10, you need to change API code previously used to determine and then adjust scale factors. The link offers some C+ code(I think?) to make the adjustments you need but I don't know how to adapt them into API code that you could use. My Windows 11 version won't let me use the above RegRead code and it seems the DPI value is at HKCU\Control Panel\Desktop\PerMonitorSettings Anyways, if anyone has the new API's needed (GetDpiForMonitor / GetDpiForWindow/
GetSystemMetricsForDpi) it sure would be helpful. HTH. Dave

[SamT]

Monitor Scaling is a Windows setting. You must look in the Windows "Hive" for that value

Search the net for "Windows 10 Registry Scale"

[Dave]

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

[chubbychub]

Dave It detects the scale level your code!!!! i need to make adjustments in the posistioning and going to test some more but was so excited and came here to post first. I will post results! but so far it its able to detect the scale!!

PD. Thank you all for the replies, i have been googling and found this but its in C + languague..i think

https://github.com/lihas/windows-DPI-scaling-sample/blob/master/README.md

[chubbychub]

where do i insert a IF and else statement in that code?
for example,
if scale zoom is between 150% to 200% , then userform appear at (x,y) position
if scale zoom is between 201% to 300%, then userform appear at (x+300, y+300) position
if scale zoom is between 301% to 400%, then userform appear at (x+600, y+600) position
if scale zoom is between 401% to 500%, then userform appear at (x+800, y+800) position

PD, those aint the real coordinates, just trying to get an idea on where to put that code than i will adjust the coordinates.

[Dave]

The "ScreenResToZoom" function is set to receive the scale and is also set up for a multiple conditions with a Case statement that can be adapted for your use. Dave

[chubbychub]

i dont know how to code vba at all

from just googling but get alot of compilation error, if anyone can correct the code i post please. apologies, is not my lack of effort, its my lack of knowledge and google cant help me.



Public Function ScreenResToZoom(DPIScaler As Double)
Select Case DPIScaler
Case Is = >100 to 200
ScreenResToZoom = 100
then Me.Top = (Application.Height - 75 - Me.Height)
Case Is = >201 to 300
ScreenResToZoom = 95
then Me.Top = (Application.Height - 100 - Me.Height)
Case Is = >301 to 400
ScreenResToZoom = 85
then Me.Top = (Application.Height - 125 - Me.Height)
Case Is = >401 to 500
ScreenResToZoom = 70
then Me.Top = (Application.Height - 150 - Me.Height)
Case Else
ScreenResToZoom = 50
then Me.Top = (Application.Height - 75 - Me.Height)
End Select
ActiveWindow.Zoom = ScreenResToZoom


End Function

[arnelgp]

Public Function ScreenResToZoom(DPIScaler As Double)
Select Case DPIScaler
Case Is < 201
ScreenResToZoom = 100
then Me.Top = (Application.Height - 75 - Me.Height)
Case Is < 301
ScreenResToZoom = 95
then Me.Top = (Application.Height - 100 - Me.Height)
Case Is < 401
ScreenResToZoom = 85
then Me.Top = (Application.Height - 125 - Me.Height)
Case Is < 501
ScreenResToZoom = 70
then Me.Top = (Application.Height - 150 - Me.Height)
Case Else
ScreenResToZoom = 50
then Me.Top = (Application.Height - 75 - Me.Height)
End Select
ActiveWindow.Zoom = ScreenResToZoom

End Function

[chubbychub]

i get red lines and when macro is ran its says compile error



Public Function ScreenResToZoom(DPIScaler As Double)
Select Case DPIScaler
Case Is = >100 to 200
ScreenResToZoom = 100
then Me.Top = (Application.Height - 75 - Me.Height) '<------red lines here
Case Is = >201 to 300
ScreenResToZoom = 95
then Me.Top = (Application.Height - 100 - Me.Height) '<------red lines here
Case Is = >301 to 400
ScreenResToZoom = 85
then Me.Top = (Application.Height - 125 - Me.Height) '<------red lines here
Case Is = >401 to 500
ScreenResToZoom = 70
then Me.Top = (Application.Height - 150 - Me.Height) '<------red lines here
Case Else
ScreenResToZoom = 50
then Me.Top = (Application.Height - 75 - Me.Height) '<------red lines here
End Select
ActiveWindow.Zoom = ScreenResToZoom


End Function

[arnelgp]

remove the word then

[Dave]

HI CC. I'm not quite sure that you want to change the sheet zoom with changes to the scale? I don't have any large monitors with that high a screen resolution or the need to scale at 400%. My largest monitor with highest scale makes all the sheet rows really thin and requires a change to the sheet zoom just to see them. So I'll assume that's what's needed. I would start with the monitor(s) at 100% scale and see how many rows are visible and then jigger with the "ScreenResToZoom" values at each scale level until the same number of rows are displayed. If you don't want to change the sheet zoom, then I left an example within the "ScreenResToZoom" function where you can adjust the userform display height for each scale (remove the zoom part and the userform placement code in the "ScreenInfo" sub.) .You will need to adjust the userform name to suit. Unfortunately, this is where you find out that the scale factor (and screen resolution) also effects the size of your userform and controls. So you will need to adjust them as well. One thing at a time. HTH. Dave

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 & "%"


UserForm1.StartUpPosition = 0
Call ScreenResToZoom(DPIScale)
UserForm1.Left = Application.Left + (0.5 * Application.Width) - (0.5 * UserForm1.Width)
UserForm1.Top = Application.Top + (0.9 * Application.Height) - (0.9 * UserForm1.Height)
UserForm1.Show
End Sub


Public Function ScreenResToZoom(DPIScaler As Double)
Select Case DPIScaler
Case 100
ScreenResToZoom = 100
Case 100 To 199
ScreenResToZoom = 85
'UserForm1.Left = Application.Left + (0.5 * Application.Width) _
- (0.5 * UserForm1.Width)
'UserForm1.Top = Application.Top + (0.9 * Application.Height) _
- (0.9 * UserForm1.Height)
Case 200 To 299
ScreenResToZoom = 70
Case 300 To 399
ScreenResToZoom = 55
Case 400 To 499
ScreenResToZoom = 40
Case Else
ScreenResToZoom = 30
End Select
ActiveWindow.Zoom = ScreenResToZoom
End Function

[chubbychub]

THANK YOU Dave and arnelgp! i have been testing and still working on placing position on userforms, just havent had access to the computers with the high resolution. But this is the something that i thought it was impossible to do.
thank you again. this solved my problem is just a matter of positioning now. nothing provide me with a solution and this forum did, great people around thank you all again for all the responses.

[Dave]

You are welcome. I never mind helping those that make a determined effort to help themselves. Thanks for posting your outcome. Dave
ps. I see this thread has become a sticky again?

[Aussiebear]

@Dave, I keep removing it as a sticky as its so unnecessary.

[Artik]

chubbychub, I can't quite understand where you want to display the Userform on the screen. From the attached image in post #9, you can see that you want to place the Userform near the bottom edge. In post #12 you are combining to make the Userform appear in different places on the screen, depending on the scale you read.
The rest of my post is about placing the Userform close to the bottom edge of the screen. With such an assumption, knowing the scale seems unnecessary. It is enough to read the displayed resolution (it is expressed in px), convert this to points (pt) and display the form in the appropriate place. The following code displays the form near the bottom edge of the screen regardless of the resolution and scale used
Option Explicit

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

Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Const LOGPIXELSX = 88 'px/logical inch
Private Const POINTS_PER_INCH As Long = 72 '1pt=1/72 inch


Sub ShowForm()
Dim ScrWidth As Single 'in pt
Dim ScrHeight As Single 'in pt
Dim PpP As Single
Dim X As Long 'in px
Dim Y As Long 'in px

PpP = PointsPerPixel
Call ScreenRes(X, Y)

ScrWidth = X * PpP ' in pt
ScrHeight = Y * PpP 'in pt

With UserForm1
.StartUpPosition = 0
.Top = ScrHeight - .Height - 20 ' in pt
.Left = (ScrWidth - .Width) / 2 ' in pt
.Show 'vbModeless
End With

End Sub


Function ScreenRes(X As Long, Y As Long) As String
Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1

X = GetSystemMetrics(SM_CXSCREEN)
Y = GetSystemMetrics(SM_CYSCREEN)
ScreenRes = X & " x " & Y
End Function


Function PointsPerPixel() As Double
Dim hDC As Long
Dim lDotsPerInch As Long

hDC = GetDC(0)
lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
PointsPerPixel = POINTS_PER_INCH / lDotsPerInch
ReleaseDC 0, hDC

End Function



About the scale.
On mine (Win 10), the GetDpi function, or more precisely the winAPI GetDeviceCaps function, always returns 96 regardless of the scale set. This may have made sense in the past (below Win 8). I can't check on an 8.1 system (because I don't have it anymore), but the function below should return a DPI that depends on the scale used. Unfortunately, it doesn't work properly in Win 10.
Option Explicit

'Probably only Win 8.1 - not tested!
Private Declare PtrSafe Function GetDpiForMonitor Lib "shcore.dll" _
(ByVal hMonitor As LongPtr, _
ByVal dpiType As Long, _
ByRef dpiX As Long, _
ByRef dpiY As Long) As Long

Private Declare PtrSafe Function MonitorFromWindow Lib "user32.dll" _
(ByVal hwnd As LongPtr, _
ByVal dwFlags As Long) As Long


Sub TestScale()
MsgBox GetWinScale(GetMonitorDPI) & " %"
End Sub


Function GetMonitorDPI() As Long
Dim hMonitor As LongPtr
Dim dpiX As Long
Dim dpiY As Long

hMonitor = MonitorFromWindow(Application.hwnd, &H2)
GetDpiForMonitor hMonitor, 0, dpiX, dpiY
GetMonitorDPI = dpiX
End Function


Function GetWinScale(DPI As Long) As Long
GetWinScale = 100 * DPI / 96
End Function


For Win 10:
Option Explicit

'Only Win 10 or greater
Private Declare PtrSafe Function GetDpiForWindow Lib "user32.dll" _
(ByVal hwnd As LongPtr) As Long


Sub TestScale()
MsgBox GetWinScale(GetMonitorDPI) & " %"
End Sub


Function GetMonitorDPI() As Long
GetMonitorDPI = GetDpiForWindow(Application.hwnd)
End Function


Function GetWinScale(DPI As Long) As Long
GetWinScale = 100 * DPI / 96
End Function

For now, I think that for the purpose of the OP task, knowledge of scale is not needed.


Artik

[Dave]

Artic thanks for posting the new API's. The GetDPI function worked until XL version 12 (07 the start of VBA7 and probably related to the MS OS change at the same time) and then always returned 96 (see my post #14). I was surprised to find it working again when I started messing around with code for this thread on Windows 11. The GetDPI also works fine on my 2 laptops with Windows 10. Your "new" API function code also work on my Windows 10 so perhaps it's a Windows 10 update version thing for you. I tend to agree with your summation but I am unable to test the real world conditions. I also use the PointPerPixel routine in combo with the screen resolution to adjust the userform size. Again, thanks. Dave

[Haval1957]

I have different display Scale level, some monitors at 100%, other s at 200%, others at 175%, others at 300 %, and userform dont display when the userform is set on the bottom of the excel sheet, (the resolution on this screen are the same at 3840 x2160 on all the screens but not SCALE)
i dont want the userform to appear in the middle, if there was a code to obtain the SCALE level , then i can put a vba code to position the userform according to scale level with a IF and else statement to position the userform accordingly. If someone can help me to code in vba about obtaining windows 11 scale level with 64bit excel 2019 please.

P.D. I have google for a couple of days and all vba code that i have found is regarding screen resolution and pixels.
Obtaining the scale level in VBA to position the userform correctly on different monitors with varying scaling settings can be a bit challenging, as there is no direct VBA method to retrieve the scale level in Windows. However, there is a workaround you can try using the Windows API.

[Paul_Hossler]

Fixed syntax errors so at least it compiles. Not tested

1. Sub instead of Function seems better
2. The # is code for Double, the editor turns 100.0 into 100#
3. No 'Then' on regular Case ....
4. An input value of 200.5 would fall through and hit the 'Else' which you probably don't want
5. Not sure what the 'Me.' refers to, but most likely a UserForm??



Option Explicit


Public Sub ScreenResToZoom(DPIScaler As Double)
Select Case DPIScaler
Case 100# To 200#
ScreenResToZoom = 100
Me.Top = (Application.Height - 75 - Me.Height)
Case 200# To 300#
ScreenResToZoom = 95
Me.Top = (Application.Height - 100 - Me.Height)
Case 300# To 400#
ScreenResToZoom = 85
Me.Top = (Application.Height - 125 - Me.Height)
Case 400# To 500#
ScreenResToZoom = 70
Me.Top = (Application.Height - 150 - Me.Height)
Case Else
ScreenResToZoom = 50
Me.Top = (Application.Height - 75 - Me.Height)
End Select


ActiveWindow.Zoom = ScreenResToZoom




End Sub

[chubbychub]

the below code worked, after a few months of changing and twisting things and trying to figure out, i finally figure out what was wrong and end up using the code below. The problem was for some reason when ran as admin, the userform didnt even show up on the screen (it was way off screen) in 8K monitors but it would appear at the bottom screen in 4k monitors and everything below 4k resolutions. but running WITHOUT admin priviledges, then the below code worked fine in ALL monitors without the windows 11 (admin prompt when opening the .XLMT file. )
my systems configurations :
Device name ChubbChu
Processor 12th Gen Intel(R) Core(TM) i9-12900K 3.19 GHz
Installed RAM 128 GB (128 GB usable)
Device ID xxxxxxxxxxxxxxxxxxxxxx
Product ID xxxxxxxxxxxxxxxxxxxxx
System type 64-bit operating system, x64-based processor
Pen and touch No pen or touch input is available for this display

with microsoft office 2021 on windows 11



Private Sub UserForm_Initialize()


Me.StartUpPosition = 0
'Me.Top = (Application.Height - Me.Height) / 2
Me.Top = (Application.Height - 75 - Me.Height) ''this is to move up or down
' Me.Left = (Application.Width - Me.Width) / 2 '''''this is to move left or right
Me.Left = Int(((Application.Width / 2) + Application.Left - 100) - (FlooringForm.Width / 2)) '''this is for center of application
Me.BoxesTotal.Locked = True
End Sub



quote from Artic "The rest of my post is about placing the Userform close to the bottom edge of the screen. With such an assumption, knowing the scale seems unnecessary. It is enough to read the displayed resolution (it is expressed in px), convert this to points (pt) and display the form in the appropriate place. The following code displays the form near the bottom edge of the screen regardless of the resolution and scale used",
thank you for this input, as you made sense and made me think of testing other things to find the problem or the compatibility of windows 11.

thank you all for answering, Paul_hosser, Haval1957, Dave, Artik, Aussiebear, and arnelgp
i added reputation, but forum didnt allow me to give out so much reputation points to everyone but i come bakc and add it in a few days.