我有一个 Excel 用户表单，我想在打开时调整大小以适应屏幕分辨率。
我通过得到高度和宽度Application.Height and Application.Width，通常使用这两个参数和以下代码，应该可以解决问题：
Me.Top = Application.Top
Me.Left = Application.Left
Me.Height = Application.Height
Me.Width = Application.Width
问题是：Windows（至少从 7 开始）有一个参数可以设置桌面缩放，这似乎会损害代码。
例如，当从 100% 更改为 150% 时，表单的宽度和高度设置正确，但缩放不正确。我想根据 Windows 桌面缩放来更改它。
如何检索桌面缩放参数？
尝试这个：
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
本文内容由网友自发贡献，版权归原作者所有，本站不承担相应法律责任。如您发现有涉嫌抄袭侵权的内容，请联系:hwhale#tublm.com(使用前将#替换为@)
