Как получить размеры границ пользовательской формы?

Question

У меня есть пользовательская форма (userform1) с несколькими элементами управления.Один элемент управления - это командная кнопка, которая открывает вторую пользовательскую форму (userform2).

Я хочу, чтобы userform2 открывалась сразу под кнопкой и центрировалась с ней.

Чтобы иметь одинаковое поведение независимо от системы/ определения тем для Windows, мне нужно знать размеры границ userform1.

После копания в течение 3 дней я использовал API-функции GetWindowRect и GetWindowClient.С помощью этих двух подпрограмм API я могу найти ВСЕГО размеры горизонтальных границ (верхняя плюс нижняя) и вертикальных границ (левая плюс правая), но не их по отдельности.

Для вертикальных границ это обычноощущение, что они будут иметь одинаковую толщину (ширину) - на самом деле, я никогда не видел окна с разными левыми и правыми границами.Таким образом, решение состоит в том, чтобы разделить на 2 общий размер.Однако для горизонтальных границ это нельзя использовать, поскольку верхняя граница обычно толще нижней.

В конце концов я нашел обходной путь для этой проблемы, но его нельзя применять всегда.То есть, если внутри userform1 есть элемент управления кадром, то API-функция GetWindowRect может использоваться для нахождения «абсолютных» координат кадра, т. Е. Ссылающихся на экран, а не на userform1.Затем размер верхней границы задается следующим образом: frame.top_Absolute - (Userform1.top_Absolute - frame.top_RelativeToUserform1).

Проблема этого подхода заключается в том, что пользовательские формы не всегда имеют элементы управления кадрами.С другой стороны, не все элементы управления имеют свойство «прямоугольник»;следовательно, GetWindowRect нельзя использовать для всех элементов управления.

Вопрос: существует ли «прямой» способ определения размера границ пользовательской формы?

Код

Вобычный модуль:

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

'В кодовой таблице Userform:

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

Answer 1

Логика:

1. Показать Userform1 как немодальный. Это необходимо для того, чтобы Userform2 мог отображаться как немодальный
2. Показать Userform2 как немодальный. Это необходимо для того, чтобы пользовательскую форму2 можно было перемещать
3. Переместить пользовательскую форму2 в соответствующую позицию

Расчет новой позиции:

Может быть намного лучше объяснено с изображением ниже

В модуле:

Option Explicit

Sub Sample()
    UserForm1.Show vbModeless
End Sub

В Userform1 область кода:

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

Скриншот

Answer 2

Теперь я могу ответить на свой вопрос после прочтения кода Сиддхарта Раута. Ключ заключается в том, чтобы использовать функцию API ClientToScreen для поиска «экранных» координат верхнего левого угла окна клиента (пользовательской формы).

Я оставляю здесь код на тот случай, если кому-то понадобится узнать размеры границ пользовательской формы.

В обычном модуле:

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

В кодовой таблице пользовательской формы:

Опция Явная

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