Excel VBA自动创建按钮跨显示器定位异常问题求助

I’ve run into this exact issue before! When moving your Excel window to a smaller secondary monitor, button positioning drifts—especially for buttons placed far to the right—because of differing display DPI scaling settings. Your original code relies directly on Cells.Top/Cells.Left properties, which use Excel’s internal "point" units, but system-level display scaling throws off the mapping between these points and actual screen pixels.

Solutions to Fix the Drift #

Option 1: Bind Buttons to Cell Ranges (Most Reliable) #

Instead of calculating positions manually, just anchor the button directly to a target cell range. This way the button will automatically snap to the cells, no matter which monitor you’re on:

Sub Add_Button(my_top As Integer, my_left As Integer, my_Width As Integer, my_Height As Integer)
    Dim targetRange As Range
    Dim myBtn As Object
    
    ' Define the range the button should cover
    Set targetRange = ActiveSheet.Cells(my_top, my_left).Resize(my_Height, my_Width)
    
    ' Create the button directly over the range
    Set myBtn = ActiveSheet.Buttons.Add(targetRange.Left, targetRange.Top, targetRange.Width, targetRange.Height)
    
    With myBtn
        .Caption = "Your Button Text" ' Replace with your desired caption (fixes the undefined "text" variable issue)
        .Name = "CustomBtn_" & Format(Now(), "YYYYMMDDHHMMSS") ' Add unique name to avoid conflicts
    End With
End Sub

' Test the updated function
Sub Test_Add_Button()
    Add_Button my_top:=2, my_left:=60, my_Width:=2, my_Height:=3
End Sub

Option 2: Correct for DPI Scaling Manually #

If you need to keep manual position calculations, use Windows API to get the current display scaling factor and adjust your coordinates accordingly:

' Declare Windows API functions to get display 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 Integer) As Integer
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As LongPtr

' Calculate current display scaling percentage
Function GetDisplayScale() As Double
    Dim hdc As LongPtr
    Dim dpiX As Integer
    Const LOGPIXELSX = 88 ' Constant for horizontal DPI
    
    hdc = GetDC(0)
    dpiX = GetDeviceCaps(hdc, LOGPIXELSX)
    ReleaseDC 0, hdc
    
    ' Standard DPI is 96; scaling factor = current DPI / 96
    GetDisplayScale = dpiX / 96
End Function

' Updated button creation with scaling correction
Sub Add_Button(my_top As Integer, my_left As Integer, my_Width As Integer, my_Height As Integer)
    Dim myBtn As Object
    Dim scaleFactor As Double
    Dim targetCell As Range
    
    scaleFactor = GetDisplayScale()
    Set targetCell = ActiveSheet.Cells(my_top, my_left)
    
    Set myBtn = ActiveSheet.Buttons.Add(1, 1, 1, 1)
    With myBtn
        ' Adjust positions using the scaling factor to offset display scaling
        .Top = targetCell.Top / scaleFactor
        .Left = targetCell.Left / scaleFactor
        .Height = targetCell.Height * my_Height / scaleFactor
        .Width = targetCell.Width * my_Width / scaleFactor
        .Caption = "Your Button Text"
    End With
End Sub

Why Your Original Code Failed #

• Excel’s Cells.Top/Cells.Left use point units (1 point = 1/72 inch), but when your monitor uses non-100% scaling, Windows automatically scales Excel’s UI elements. This breaks the 1:1 mapping between calculated points and actual screen pixels.
• The drift gets worse for right-aligned buttons because the scaling error accumulates across every column width.

Quick Notes #

• Save your file as .xlsm to preserve macros.
• Your original code had an undefined text variable for the button caption—make sure to replace that with a specific string or pass it as a parameter!

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