Question

我有一个带有多个控件的用户窗体（userform1）。一个控件是一个命令按钮，它将打开第二个用户窗体（userform2）。

我希望userform2立即在按钮下方打开并居中。

要在Windows的系统/主题定义中都具有相同的行为，我需要知道userform1的边框大小。

在3天的挖掘之后，我使用了API函数GetWindowRect和GetWindowClient。通过这两个API例程，我可以找到水平边框（上下加）和垂直边框（左加右）的TOTAL大小，但不能分别找到它们。

对于垂直边框，通常具有相同的厚度（宽度）是常识-实际上，我从未见过带有不同左右边框的窗口。因此，解决方案是将总大小除以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

'在用户表单代码表中：

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

逻辑：

将Userform1显示为无模式。这是必需的，以便Userform2可以显示为无模式
将Userform2显示为无模式。这是必需的，以便可以移动Userform2
将Userform2移至相关位置

新排名计算：

下面的图片可以更好地解释

在模块中：

<Grid>
    <Grid.RowDefinitions>
        <RowDefinition Height="Auto" />
        <RowDefinition Height="Auto" />
    </Grid.RowDefinitions>

    <!-- Origin -->
    <Grid Grid.Row="0">
        <Grid.ContextMenu>
            <ContextMenu>
                <ContextMenu.ItemsSource>
                    <CompositeCollection>
                        <MenuItem Header="Copy origin addresses" />
                        <MenuItem Header="Copy both addresses" />
                    </CompositeCollection>
                </ContextMenu.ItemsSource>
            </ContextMenu>
        </Grid.ContextMenu>
        <TextBlock Text="Origin" />
    </Grid>

    <!-- Destination -->
    <Grid Grid.Row="1">
        <Grid.ContextMenu>
            <ContextMenu>
                <ContextMenu.ItemsSource>
                    <CompositeCollection>
                        <MenuItem Header="Copy destination addresses" />
                        <MenuItem Header="Copy both addresses" />
                    </CompositeCollection>
                </ContextMenu.ItemsSource>
            </ContextMenu>
        </Grid.ContextMenu>
        <TextBlock Text="Destination" />
    </Grid>
</Grid>

在Option Explicit Sub Sample() UserForm1.Show vbModeless End Sub代码区域：

Userform1

屏幕截图

Answer 2

阅读Siddharth Rout的代码后，我现在可以回答自己的问题。关键是使用ClientToScreen API函数查找（用户窗体的）客户端窗口左上角的“屏幕”坐标。

如果有人需要知道用户表单的边框大小，我将在此处保留代码。

在普通模块中：

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

如何获得用户表格的边框大小？

2 个答案: