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

我有一个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桌面缩放进行更改

如何检索桌面缩放参数？

试试这个：

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

试试这个：

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

试试这个：

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

试试这个：

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

---

---

你试过在用户窗体上使用全屏模式吗？它是否适用于您的应用程序？我输入的代码可以将Userform放在全屏上，因为

Private Declare PtrSafe函数GetSystemMetrics Lib“USER32”（ByVal nIndex As Long），只要

刚刚获得分辨率。我了解到您可以从注册表项获取缩放参数。您应该询问与windows libs编程相关的标记，他们可能会更清楚。谢谢您的回答。有人能告诉我excel UserForm上的zoom属性会产生什么影响吗。更改时，它似乎会修改字体大小、控件的位置，但listView的字体大小似乎没有更改您是否尝试在UserForm上使用全屏模式？它是否适用于您的应用程序？我输入的代码可以将Userform放在全屏上，因为

Private Declare PtrSafe函数GetSystemMetrics Lib“USER32”（ByVal nIndex As Long），只要

刚刚获得分辨率。我了解到您可以从注册表项获取缩放参数。您应该询问与windows libs编程相关的标记，他们可能会更清楚。谢谢您的回答。有人能告诉我excel UserForm上的zoom属性会产生什么影响吗。更改时，它似乎修改了字体大小和控件的位置，但listView的字体大小似乎没有改变。正确的VBA7声明是：

Private Declare PtrSafe Function GetDC Lib“user32”（ByVal hwnd As LongPtr）As LongPtr

Private Declare PtrSafe Function GetDeviceCaps Lib“gdi32”（ByVal hDC作为LongPtr，ByVal nIndex作为Long）只要Long

（单独的注释以确保这些单独的代码行不会连接到单个文本块）此外，您还需要pointsperpix（）中的条件声明块，将hdc声明为Long和as LongPtr-别担心，绝大多数已发布的VBA指针安全声明都是错误的，您的声明也不太危险：但我更愿意看到其他开发人员的好例子。@NigelHeffernan我更新了声明。谢谢。正确的VBA7声明是：

Private Declare PtrSafe FunctionGetDC Lib“user32”（ByVal hwnd作为LongPtr）作为LongPtr

私有声明PtrSafe函数GetDeviceCaps Lib“gdi32”（ByVal hDC作为LongPtr，ByVal nIndex作为Long）作为LongPtr

（单独的注释以确保这些单独的代码行不会连接到单个文本块中）此外，在pointsperpix（）中还需要一个条件声明块，将hdc声明为Long和LongPtr-别担心，绝大多数已发布的VBA指针安全声明都是错误的，而您的声明并不十分危险：但我更希望看到其他开发人员的好例子。@NigelHeffernan我更新了声明。谢谢。