Is there any way to get display zoom value of Windows? The 200% in the picture is exactly what I would like to get.
This question is only half the means to achieve another purpose, which is formulated in that question: Excel Shape position disturbed by Windows Display Zoom settings
You can retrieve this information with a WIN32-API call
Option Explicit
Private Const LOGPIXELSX As Long = 88
#If VBA7 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
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function EnumDisplayMonitors Lib "user32" (ByVal hdc As LongPtr, ByRef lprcClip As Any, ByVal lpfnEnum As LongPtr, ByVal dwData As Long) As Long
#Else
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function EnumDisplayMonitors Lib "user32" (ByVal hdc As Long, ByRef lprcClip As Any, ByVal lpfnEnum As Long, ByVal dwData As Long) As Long
#End If
Public Function GetDpi() As Long
#If VBA7 Then
Dim hdcScreen As LongPtr
Dim hWnd As LongPtr
#Else
Dim hdcScreen As Long
Dim hWnd As Long
#End If
hWnd = GetActiveWindow()
hdcScreen = GetDC(hWnd)
Dim iDPI As Long
iDPI = -1
If (hdcScreen) Then
iDPI = GetDeviceCaps(hdcScreen, LOGPIXELSX)
ReleaseDC hWnd, hdcScreen
End If
GetDpi = iDPI
End Function
This will result in 192 for eg 200%:
96 – Smaller 100%
120 – Medium 125%
144 – Larger 150%
192 – Extra Large 200%
240 – Custom 250%
288 – Custom 300%
384 – Custom 400%
480 – Custom 500%
Related
Hello can you somone tell me how make this macros to run on 32 bit and on 64 bit Office?
on 32 bit macros is run but on 64 bit it not and it is in red color. Thank you.
Public Declare Function CreatePopupMenu Lib "user32" () As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long`
Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Public Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long
Public Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long```
I was using code that was working fine when I was running the 32-bit version of Excel. After I was switched to the 64-Bit version, the macro broke. I updated the dll calls to use LongPtr everywhere instead of Long.
Is there any way to determine which arguments and return types need to be changed for VBA7, and which don't, for a specific Declare Function?
Here is an example of some of the "Declare Functions" that I have updated (there were actually several more too).
#If VBA7 Then
Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As LongPtr, ByVal nHeight As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As LongPtr
Private Const LOGPIXELSY As Long = 90
#Else
Private Declare CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Const LOGPIXELSY As Long = 90
#End If
This code was adapted from an answer to this question:
vb macro string width
Relevant snippet is copied here below:
Private Function GetLabelSize(text As String, font As StdFont) As SIZE
Dim tempDC As Long
Dim tempBMP As Long
Dim f As Long
Dim lf As LOGFONT
Dim textSize As SIZE
tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
I get a runtime error that just says "Compile Error: Type Mismatch." The function call to CreateDC is highlighted, and the debugger breaks on the function GetLabelSize. I have no idea which variable is now causing the error. I'm also assuming that once I fix this first error, I'll have other errors too.
Do I need to pass the value of that last argument (ByVal 0) as an explicitly typed variable? If so how?
I updated the dll calls to use LongPtr everywhere instead of Long.
You should have not done that.
By adding PtrSafe to a function declaration, you promise to the compiler that you have put LongPtr in all places where it needs to be, and nowhere else.
LongPtr is a pointer-sized integer. It must be used for things that have the same size as a pointer.
To learn which Windows API types should be described as LongPtr, you must look at the original function signature, consult https://learn.microsoft.com/en-us/windows/win32/winprog/windows-data-types, track the used data types through all the typedefs down to the basic types, and use LongPtr for those that are pointers to things.
For the functions that you have shown, that would be
#If VBA7 Then
Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As Long
#Else
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
#End If
When you declare variables to hold your LongPtr results, you need to use #If VBA7 too:
#If VBA7 Then
Dim tempDC As LongPtr
Dim tempBMP As LongPtr
#Else
Dim tempDC As Long
Dim tempBMP As Long
#End If
If you don't have to support Office 2007 and older, you can ditch the #If VBA7s and only use the LongPtr branch.
Im trying to run a macro code but since I'm using a 64 bit Excel 2016 this code is not working. Please help me how to fix this.
Private Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As Long, ByRef lpiid As GUID) As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" _
(ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As GUID, _
ByRef ppvObject As Object) As Long
These should work on 64 bit Excel
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function IIDFromString Lib "ole32" _
(ByVal lpsz As LongPtr, ByRef lpiid As GUID) As Long
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" _
(ByVal Hwnd As LongPtr, ByVal dwId As Long, ByRef riid As GUID, _
ByRef ppvObject As Object) As Long
If you need it to run on both you can use the following #If VBA7
#If VBA7 Then
'64 bit declares here
#Else
'32 bit declares here
#End If
A nice resource for PtrSafe Win32 API declares can be found here: Win32API_PtrSafe.txt
We need to do following two code changes:
Replace Long data type with LongPtr, at all places in the
script
You need to change the private function declarations as
below:
OLD:
Private Declare Function GetTimeZoneInformation Lib "kernel32" ( _
lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
NEW:
Private Declare PtrSafe Function GetTimeZoneInformation Lib "kernel32" ( _
lpTimeZoneInformation As TIME_ZONE_INFORMATION) As LongPtr
I wrote a large VBA program which, in a nutshell, calculates the energy need of buildings. It would be way to much code to post here but firstly it reads a configuration file for each building, then loads some heat load profiles from the disk and then dynamically calculates for 35040 quarter hours which heat producers generates what amount of heat.
On Windows 7 with Windows Defender it just runs smooth and fine, no matter what Excel Version (2007, 2010, 2013, 365 tested).
Now, if I'm running the same code on my computer with Windows 10 and Windows Defender (Excel 365), it is slower by an incredible amount (factor 1000 or so it feels). And strangely, everything is way slower, it is not a certain procedure or event. Loading the files and profiles from the disk takes forever, but calculating the energy needs in the loop (where nothing is transferred from/to the drive) is way slower aswell. The GUI isn't refreshing at all and the whole application just seems frozen.
At the same time MsMpEng.exe is on full load, suggesting Windows Defender has a problem. And surprise, having turned off Windows Defender, everything runs fine.
Now, because there are so many classes/modules/etc. it is hard to say, what may be the problem and I can't upload the code. But at least I have a suspicion. Every class has a Parent Property, implemented as depicted here.
The parent property is called very often and all over the code so the extreme slow down would make sense if there was a problem with the CopyMemory-API/Function.
Update 1:
I removed the CopyMemory-Function and replaced all the Parents with Circular References. This is no long term solution, but it solved part of the problem. When I wait long enough the calculation starts at some point and is as fast as it's supposed to be. So the problem could be related to API-Functions in general because I use quite a lot for the GUI, namely
Public Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Public Declare PtrSafe Function GetDeviceCaps Lib "Gdi32" (ByVal hDC As LongPtr, ByVal _
nIndex As Long) As Long
Public Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal _
hDC As LongPtr) As Long
Public Declare PtrSafe Function GetSystemMetrics32 Lib "user32" _
Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Public Declare PtrSafe Function SetWindowPos Lib "user32" _
(ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Public Declare PtrSafe Sub ReleaseCapture Lib "user32" ()
Public Declare PtrSafe Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" _
(ByVal hInst As LongPtr, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As LongPtr
Public Declare PtrSafe Function GetActiveWindow32 Lib "user32" Alias "GetActiveWindow" () As Integer
#If Win64 Then
Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" _
(ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" _
(ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If
Update 2 (which makes the topic in a way solved):
The reason for the loading-part of the program took so long is because I used the JSON-Converter. And as it turns out there was a similar problem. Since I updated the module and removed every other API-Call everything runs fine and smooth. So it is definitly caused by the API-Calls though I don't know why there aren't that many other people complaining about the huge performance issues. And now I can't tweak the GUI in the way I wan't to and I don't really know how to implement the parent property properly.
I have a userform (userform1) with several controls. One control is a command button which will open a second userform (userform2).
I want that userform2 opens immediately bellow the button and centered with it.
To have the same behavior regardless the system/themes definitions for Windows, I need to know the sizes of the borders of userform1.
After digging during 3 days, I used API functions GetWindowRect and GetWindowClient. With these two API routines, I can find the TOTAL sizes of the horizontal borders (upper plus lower) and of the vertical borders (left plus right), but not them individually.
For vertical borders, it is common sense that they will have the same thickness (width) — in fact, I’ve never seen a window with different left and right borders. So, the solution is to divide by 2 the total size. However, for horizontal borders this cannot be used, since the upper border is usually thicker that the lower.
Eventually, I found a workaround for the problem, but it cannot be applied always. That is, if there is a frame control inside userform1, then the API function GetWindowRect can be used to find the “absolute” coordinates of the frame, i.e., referred to the screen, not to userform1. Then, the upper border size is given by: frame.top_Absolute – (Userform1.top_Absolute - frame.top_RelativeToUserform1).
The problem of this approach is, userforms have not frame controls always. On the other hand, not all controls have a “rectangle” property; therefore, GetWindowRect cannot be used for all controls.
Question: is there a “direct” way to find the size of the borders of a userform?
Code
In an ordinary module:
Option Explicit
'API Declarations
#If VBA7 Then
Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal Index As Long) As Long
Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnD As Long) As Long
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnD As Long, ByVal hDC As Long) As Long
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#Else
Declare Function GetSystemMetrics Lib "user32" (ByVal Index As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hWnD As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnD As Long, ByVal hDC As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare Function GetClientRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Type udtRECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type BorderSize
TopHeight As Long
LeftWidth As Long
BottomHeight As Long
RightWidth As Long
End Type
Public FormBorders As BorderSize
'To determine the sizes of the borders
Public Sub GetFormBorders(ByVal FormHandler As Long, ByVal FrameHandler As Long)
Dim rectForm As udtRECT
Dim rectFrame As udtRECT
Dim rectClientForm As udtRECT
Dim Trash As Long
Trash = GetWindowRect(FormHandler, rectForm)
Trash = GetWindowRect(FrameHandler, rectFrame)
Trash = GetClientRect(FormHandler, rectClientForm)
FormBorders.TopHeight = ConvertPixelsToPoints(rectFrame.Top - rectForm.Top, "Y") - frmFlyschGSI.fraRockProp.Top 'userform1.frame.top
FormBorders.LeftWidth = ConvertPixelsToPoints(rectFrame.Left - rectForm.Left, "X") - frmFlyschGSI.fraRockProp.Left
FormBorders.BottomHeight = ConvertPixelsToPoints(rectForm.Bottom - rectForm.Top, "Y") - FormBorders.TopHeight - _
ConvertPixelsToPoints(rectClientForm.Bottom - rectClientForm.Top, "Y")
FormBorders.RightWidth = ConvertPixelsToPoints(rectForm.Right - rectForm.Left, "X") - FormBorders.LeftWidth - _
ConvertPixelsToPoints(rectClientForm.Right - rectClientForm.Left, "X")
Debug.Print FormBorders.TopHeight, FormBorders.LeftWidth, FormBorders.BottomHeight, FormBorders.RightWidth
End Sub
'To convert pixels to points
Public Function ConvertPixelsToPoints(ByVal sngPixels As Single, ByVal sXorY As String) As Single
'Credits to: https://bettersolutions.com/vba/userforms/positioning.htm
Dim hDC As Long
hDC = GetDC(0)
If sXorY = "X" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 88))
End If
If sXorY = "Y" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 90))
End If
Call ReleaseDC(0, hDC)
End Function
'In the Userform code sheet:
Option Explicit
Private Sub UserForm_Initialize()
'Some code here
If Me.Visible = False Then
Call GetFormBorders(FindWindow(vbNullString, frmFlyschGSI.Caption), frmFlyschGSI.fraRockProp.[_GethWnd])
End If
'More code here
End Sub
Private Sub cmdMiHarder_Click()
Dim FrameBorder As udtRECT
Dim Trash As Long
Dim sngTopBorder As Single
Dim sngLeftBorder As Single
'Some code here
Trash = GetWindowRect(Me.fraRockProp.[_GethWnd], FrameBorder)
sngTopBorder = ConvertPixelsToPoints(FrameBorder.Top, "Y") - (Me.Top + Me.fraRockProp.Top)
sngLeftBorder = ConvertPixelsToPoints(FrameBorder.Left, "X") - (Me.Left + Me.fraRockProp.Left)
'More code here
End Sub
Logic:
Show Userform1 as modeless. This is required so that Userform2 can be shown as modeless
Show Userform2 as modeless. This is required so that Userform2 can be moved
Move Userform2 to the relevant position
New Position Calculations:
Can be much better explained with the below image
In a Module:
Option Explicit
Sub Sample()
UserForm1.Show vbModeless
End Sub
In Userform1 code area:
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetDeviceCaps Lib "Gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hDC As Long) 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 LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Type POINTAPI
x As Long
y As Long
End Type
Private Const HWND_TOP = 0
Private Const SWP_NOSIZE = &H1
Private Sub CommandButton1_Click()
RepositionForm UserForm2, CommandButton1
End Sub
Public Sub RepositionForm(f As Object, c As Object)
Dim P As POINTAPI
Dim meHwnd As Long, hwnd As Long
meHwnd = FindWindow(vbNullString, Me.Caption)
P.x = (c.Left - (f.Width / 4)) / PointsPerPixelX
P.y = (c.Top + c.Height) / PointsPerPixelY
'~~> The ClientToScreen function converts the client coordinates
'~~> of a specified point to screen coordinates.
ClientToScreen meHwnd, P
UserForm2.Show vbModeless
'~~> Get Handle of Userform2
hwnd = FindWindow("ThunderDFrame", "UserForm2")
'~~> Move the form to relevant location
SetWindowPos hwnd, HWND_TOP, P.x, P.y, 0, 0, SWP_NOSIZE
End Sub
Private Function PointsPerPixelX() As Double
Dim hDC As Long
hDC = GetDC(0)
PointsPerPixelX = 72 / GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC 0, hDC
End Function
Public Function PointsPerPixelY() As Double
Dim hDC As Long
hDC = GetDC(0)
PointsPerPixelY = 72 / GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC 0, hDC
End Function
Screenshot
I can answer to my own question now after reading Siddharth Rout’s code. The key is to use the ClientToScreen API function to find the “screen” coordinates of the upper left corner of the client window (of the userform).
I am leaving here the code, in case someone needs to know the border sizes of a userform.
In a ordinary module:
Option Explicit
'
'API Declarations
'
#If VBA7 Then
Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnD As Long) As Long
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnD As Long, ByVal hDC As Long) As Long
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hWnD As Long, ByRef lpPoint As PointAPI) As Long
#Else
Declare Function GetDC Lib "user32" (ByVal hWnD As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnD As Long, ByVal hDC As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare Function GetClientRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function ClientToScreen Lib "user32" (ByVal hWnD As Long, ByRef lpPoint As PointAPI) As Long
#End If
'
Public Type udtRECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'
Public Type PointAPI
x As Long
y As Long
End Type
'
Public Type BorderSize
TopHeight As Single
LeftWidth As Single
BottomHeight As Single
RightWidth As Single
End Type
'
' To determine the sizes of the borders
'
Public Function FormBorders(ByVal FormHandler As Long) As BorderSize
'
' Credits to Siddharth Rout for the usage of ClientToScreen API function in this context.
'
Dim rectWindow As udtRECT
Dim rectClient As udtRECT
Dim P As PointAPI
Dim VerBorders As Single
Dim HorBorders As Single
Dim Trash As Long
'
Trash = GetWindowRect(FormHandler, rectWindow)
Trash = GetClientRect(FormHandler, rectClient)
'
' Sets the upper left corner of the "client" window...
P.x = 0
P.y = 0
Trash = ClientToScreen(FormHandler, P) '...and gets its screen coordinates.
'
' Total dimensions of the borders in points, after converting pixels to points:
VerBorders = ConvertPixelsToPoints((rectWindow.Right - rectWindow.Left) - (rectClient.Right - rectClient.Left), "X")
HorBorders = ConvertPixelsToPoints((rectWindow.Bottom - rectWindow.Top) - (rectClient.Bottom - rectClient.Top), "Y")
'
' Now the individual borders, one by one, in points:
FormBorders.TopHeight = ConvertPixelsToPoints(P.y - rectWindow.Top, "Y")
FormBorders.BottomHeight = HorBorders - FormBorders.TopHeight
FormBorders.LeftWidth = ConvertPixelsToPoints(P.x - rectWindow.Left, "X")
FormBorders.RightWidth = VerBorders - FormBorders.LeftWidth
'
Debug.Print FormBorders.TopHeight, FormBorders.LeftWidth, FormBorders.BottomHeight, FormBorders.RightWidth
'
End Function
'
'To convert pixels to points
'
Public Function ConvertPixelsToPoints(ByVal sngPixels As Single, ByVal sXorY As String) As Single
'
'Credits to: https://bettersolutions.com/vba/userforms/positioning.htm
'
Dim hDC As Long
'
hDC = GetDC(0)
If sXorY = "X" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 88))
End If
'
If sXorY = "Y" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 90))
End If
Call ReleaseDC(0, hDC)
'
End Function
In the code sheet of the userform:
Option Explicit
Private Sub UserForm_Initialize()
'
Dim MeBorders As BorderSize
MeBorders = FormBorders(FindWindow(vbNullString, Me.Caption))
Debug.Print MeBorders.TopHeight, MeBorders.LeftWidth, MeBorders.BottomHeight, MeBorders.RightWidth
End Sub