VBA UserForm图片跨电脑显示大小不一致问题求助

• 强制DPI适配与动态缩放
  在UserForm初始化事件中添加代码，固定控件的像素基准，并根据系统DPI动态调整尺寸：

' UserForm代码模块
Private Declare Function GetDpiForWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Sub UserForm_Initialize()
    Me.ScaleMode = fmScaleModePixels
    Me.AutoScaleMode = fmAutoScaleModeNone
    
    ' 调用DPI适配函数
    AdjustControlsForDPI Me
End Sub

Private Sub AdjustControlsForDPI(frm As UserForm)
    Dim dpi As Long
    Dim hwnd As Long
    Dim scaleFactor As Double
    
    hwnd = FindWindow("ThunderDFrame", frm.Caption)
    dpi = GetDpiForWindow(hwnd)
    scaleFactor = dpi / 96 ' 标准DPI为96
    
    ' 以图片按钮Image1为例，设置基准尺寸后按比例缩放
    With frm.Image1
        .Left = 20 * scaleFactor
        .Top = 20 * scaleFactor
        .Width = 100 * scaleFactor
        .Height = 50 * scaleFactor
    End With
    ' 其他控件同理调整
End Sub

• 设置图片控件的缩放模式
  将图片控件的PictureSizeMode属性设置为保持比例或拉伸填充，确保图片适配控件尺寸：

Private Sub UserForm_Initialize()
    ' 保持图片比例缩放，避免变形
    Image1.PictureSizeMode = fmPictureSizeModeZoom
    ' 若需要填充控件可用：fmPictureSizeModeStretch
End Sub

• 全局高DPI兼容性设置
  通过修改注册表强制Excel启用高DPI感知，适配不同电脑的显示设置（需管理员权限）：

' 标准模块代码
Sub SetExcelHighDPIAware()
    Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
    
    On Error Resume Next
    ' 写入注册表项，让Excel自身处理DPI缩放
    WshShell.RegWrite "HKCU\Software\Microsoft\Windows NT\CurrentVersion\AppCompatFlags\Layers\" & _
                      Application.Path & "\EXCEL.EXE", "~HIGHDPIAWARE", "REG_SZ"
    On Error GoTo 0
End Sub

注意事项 #

• 测试时覆盖常见DPI缩放比例（100%、125%、150%），确保多电脑环境下显示一致
• 优先使用高分辨率图片素材，避免缩放后出现模糊

内容的提问来源于stack exchange，提问作者Edoardo