根据屏幕分辨率调整用户窗体大小 [英] Userform resizing according to screen resolution

问题描述

我有一个 Excel 用户表单，我想在打开时调整其大小以适应屏幕分辨率.

I have an Excel userform I want to resize on opening to fit the screen resolution.

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

I get the height and the width through Application.Height and Application.Width, and normally with these two parameters and the following code, one should do the trick:

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

这里是问题所在:Windows(至少从 7 开始)有一个参数来设置桌面上的缩放，而这似乎损害了代码.

Here is the problem: Windows (at least since 7) has a parameter to set the zoom on the desktop, and this seems to compromise the code.

例如，当从 100% 更改为 150% 时，表单的宽度和高度设置正确，但缩放比例不正确.我想根据 Windows 桌面缩放更改它.

When changing from 100% to 150% for example, the form's width and height are set correctly but the zoom isn't. I'd like to change it according to Windows desktop zoom.

如何检索桌面缩放参数?

How can I retrieve the Desktop zoom parameter?

推荐答案

试试这个:

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

这篇关于根据屏幕分辨率调整用户窗体大小的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！