用户窗体根据屏幕分辨率进行调整大小

Question

我有一个Excel用户窗体，我希望在打开时调整大小以适应屏幕分辨率。

我通过Application.Height和Application.Width获取高度和宽度，通常使用这两个参数和以下代码，就可以解决问题：

Me.Top = Application.Top
Me.Left = Application.Left
Me.Height = Application.Height
Me.Width = Application.Width

这里是问题所在：Windows（至少从7开始）有一个参数可以设置桌面缩放，这似乎会影响代码。

当从100%更改为150%时，表单的宽度和高度被正确设置，但缩放比例不正确。我希望根据Windows桌面缩放比例进行更改。

如何检索桌面缩放参数？

- GigaByte123

---

你尝试在用户窗体上使用全屏模式了吗？它对你的应用程序有帮助吗？ - danieltakeshi

我放置的代码可以使用户窗体全屏显示。 - GigaByte123

由于Private Declare PtrSafe Function GetSystemMetrics Lib "USER32" (ByVal nIndex As Long) As Long只是获取分辨率。我读到可以从注册表项中获取缩放参数。你应该在与Windows libs编程有关的标签上提问，他们可能更了解。 - danieltakeshi

谢谢您的回答。有人能指导一下我Excel UserForm上的缩放属性影响什么吗？当更改它时，似乎会修改字体大小、控件位置，但listView的字体大小似乎没有变化。 - GigaByte123

Answer 1

试试这个：

Option Explicit
'Function to get screen resolution
#If VBA7 Then
    Private Declare PtrSafe Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As LongPtr) As Long
    'Functions to get DPI
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr 
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
#Else
    Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
    'Functions to get DPI
    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
#End If
Private Const LOGPIXELSX = 88  'Pixels/inch in X
Private Const POINTS_PER_INCH As Long = 72 'A point is defined as 1/72 inches

'Return DPI
Public Function PointsPerPixel() As Double
'hDC LongPtr if VBA7
 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

Private Sub UserForm_Initialize()

Dim w As Long, h As Long
    w = GetSystemMetrics32(0) ' Screen Resolution width in points
    h = GetSystemMetrics32(1) ' Screen Resolution height in points
With Me
    .StartUpPosition = 2
    .Width = w * PointsPerPixel * 0.5 'Userform width= Width in Resolution * DPI * 50%
    .Height = h * PointsPerPixel * 0.5 'Userform height= Height in Resolution * DPI * 50%
End With
End Sub

- Lo Bellin

---

Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr - Nigel Heffernan

Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long - Nigel Heffernan

同时，在PointsPerPixel()中，您需要一个条件声明块，将hdc声明为Long和LongPtr。不用担心，绝大多数已发布的VBA指针安全声明都是错误的，而您的声明并不会有什么危险：但我更希望看到其他开发人员的好例子。 - Nigel Heffernan

@NigelHeffernan，我更新了声明。谢谢。 - Lo Bellin

Answer 2

Private Sub UserForm_Initialize()

    With Application

        Dim WD As Long
        Dim HD As Long
        Dim OrigW As Long
        Dim OrigH As Long

        Me.Width = 980.25 'Size the UserFrom was designed to
        Me.Height = 336.75 'Size the UserFrom was designed to
        WD = (Me.Width - Me.InsideWidth)
        HD = (Me.Height - Me.InsideHeight)
        OrigW = Me.Width
        OrigH = Me.Height

        Me.Width = (Application.Width / 1.481632653) 'The number you 
        'divide by should give you the original width of the UserForm 
        
        Me.Height = (((OrigH - HD) / (OrigW - WD)) * (Me.Width - WD))+HD

        Zoom = (((Me.Width) / OrigW) * 100)

        Me.Top = (Application.Height / 2) - (Me.Height / 2)
        Me.Left = (Application.Width / 2) - (Me.Width / 2)

    End With

End Sub

- Martin

---

欢迎来到Stack Overflow。这个问题已经存在近4.5年，并且已经有两个回答。这段代码与已有的代码有何不同之处，它为什么更好？当代码配合解释说明时，效果更佳。请参考[答案]。 - Chris

Answer 3

Try this one:

  Private Sub UserForm_Initialize()
    With Application
    .WindowState = xlMaximized
    Zoom = Int(.Width / Me.Width * 100)
    Width = .Width
    Height = .Height
   End With
  End Sub

- mij nivek