Zoom缩放实现Chart Object导出放大的VBA代码在同事机器失效

问题背景 #

我编写的VBA代码通过调整Excel窗口缩放至200%，导出双倍尺寸的图表，本地运行正常，但同事电脑上缩放导出的功能失效——仅显示器设置与我不同，Excel和Windows版本完全一致。

相关代码片段：

'This chunk of code essentially controls a Scaling Factor so that we can control should pictures be normal, 2x? 3x?
'Note this code doesn't affect table size just bar chart size.

Workbooks("Twenty Year Graphs and Data.xlsx").Activate
Dim wsh As Worksheet
For Each wsh In ActiveWorkbook.Worksheets
wsh.Activate
ActiveWindow.Zoom = 200
Next wsh


'This chunk of code creates seperate chart objects for each graph and exports them

Application.CutCopyMode = False
Dim CAC As ChartObject
Dim ASHP As ChartObject
Dim CACASHP As ChartObject
Dim CGSWH As ChartObject
Dim CESWH As ChartObject
Dim CSWH As ChartObject
Dim RGASWH As ChartObject
Dim REASWH As ChartObject
Dim RASWH As ChartObject
Dim GWAF As ChartObject
Dim OWAF As ChartObject
Dim Furnaces As ChartObject


Set CAC = Sheets("CAC and ASHP").ChartObjects("CAC")
Set ASHP = Sheets("CAC and ASHP").ChartObjects("ASHP")
Set CACASHP = Sheets("CAC and ASHP").ChartObjects("CAC & ASHP")
Set CGSWH = Sheets("CSWH").ChartObjects("CGSWH")
Set CESWH = Sheets("CSWH").ChartObjects("CESWH")
Set CSWH = Sheets("CSWH").ChartObjects("CSWH")
Set RGASWH = Sheets("RSWH").ChartObjects("RGASWH")
Set REASWH = Sheets("RSWH").ChartObjects("REASWH")
Set RASWH = Sheets("RSWH").ChartObjects("RASWH")
Set GWAF = Sheets("Furnaces").ChartObjects("GWAF")
Set OWAF = Sheets("Furnaces").ChartObjects("OWAF")
Set Furnaces = Sheets("Furnaces").ChartObjects("Furnaces")
CAC.Activate
ActiveChart.Export "\\EgnyteDrive\ahri\Shared\AHRI General Share (AllShare)\Data Services\Statistics\AHRI Website Content\AHRI Website Yearly Public Historical Data\" & TwentyYears & "-" & LastYear & " Historical Data\" & "Central Air Conditioners Chart" & ".jpg"

问题根源 #

问题出在Windows系统显示缩放比例的差异上：

• 你的电脑系统缩放为100%，设置Excel Zoom=200%时，实际显示缩放就是200%，导出图片尺寸自然翻倍。
• 同事的电脑如果设置了非100%的系统缩放（比如125%、150%），Excel的200%窗口缩放会被系统缩放抵消，实际有效缩放达不到200%，导致导出图片尺寸无变化。

解决方案 #

方案1：直接调整图表尺寸后导出（最稳定） #

先将ChartObject的宽高翻倍，导出后恢复原尺寸，完全不受系统设置影响：

Sub ExportScaledChart()
    Dim originalWidth As Double, originalHeight As Double
    Dim exportPath As String
    
    ' 定义导出路径
    exportPath = "\\EgnyteDrive\ahri\Shared\AHRI General Share (AllShare)\Data Services\Statistics\AHRI Website Content\AHRI Website Yearly Public Historical Data\" & TwentyYears & "-" & LastYear & " Historical Data\" & "Central Air Conditioners Chart" & ".jpg"
    
    ' 记录图表原尺寸
    originalWidth = CAC.Width
    originalHeight = CAC.Height
    
    ' 将图表放大至2倍
    CAC.Width = originalWidth * 2
    CAC.Height = originalHeight * 2
    
    ' 导出图表
    CAC.Chart.Export exportPath
    
    ' 恢复图表原尺寸
    CAC.Width = originalWidth
    CAC.Height = originalHeight
End Sub

方案2：通过剪贴板设置导出分辨率 #

复制图表为图片后调整缩放比例再导出，适合需要更高清晰度的场景：

Sub ExportHighResChart()
    Dim exportPath As String
    exportPath = "\\EgnyteDrive\ahri\Shared\AHRI General Share (AllShare)\Data Services\Statistics\AHRI Website Content\AHRI Website Yearly Public Historical Data\" & TwentyYears & "-" & LastYear & " Historical Data\" & "Central Air Conditioners Chart" & ".jpg"
    
    ' 复制图表到剪贴板
    CAC.CopyPicture xlScreen, xlBitmap
    
    ' 创建临时工作表处理图片
    Dim tempSheet As Worksheet
    Set tempSheet = ThisWorkbook.Sheets.Add
    tempSheet.Shapes.Paste.Select
    
    ' 按200%比例放大图片并导出
    With Selection.ShapeRange
        .PictureFormat.Resize 200, 200
        .Export exportPath
    End With
    
    ' 删除临时工作表
    Application.DisplayAlerts = False
    tempSheet.Delete
    Application.DisplayAlerts = True
End Sub

方案3：适配系统缩放修正窗口Zoom值 #

如果坚持使用窗口缩放方式，先获取系统缩放比例，计算对应Excel Zoom值：

' 声明API获取系统DPI（适配32/64位Excel）
#If VBA7 Then
    Private Declare PtrSafe Function GetDpiForWindow Lib "user32.dll" (ByVal hWnd As LongPtr) As Integer
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32.dll" () As LongPtr
#Else
    Private Declare Function GetDpiForWindow Lib "user32.dll" (ByVal hWnd As Long) As Integer
    Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
#End If

' 获取系统显示缩放比例
Function GetSystemScale() As Double
    Dim dpi As Integer
    dpi = GetDpiForWindow(GetDesktopWindow())
    GetSystemScale = dpi / 96 ' 96为默认DPI（100%缩放）
End Function

' 设置正确的Excel窗口缩放
Sub SetAdjustedZoom()
    Dim systemScale As Double
    systemScale = GetSystemScale()
    
    ' 计算目标Zoom值，确保实际有效缩放为200%
    Dim targetZoom As Integer
    targetZoom = 200 * systemScale
    
    Workbooks("Twenty Year Graphs and Data.xlsx").Activate
    Dim wsh As Worksheet
    For Each wsh In ActiveWorkbook.Worksheets
        wsh.Activate
        ActiveWindow.Zoom = targetZoom
    Next wsh
End Sub

调用SetAdjustedZoom代替原代码中设置Zoom的部分，导出完成后再恢复为100 * systemScale的Zoom值即可。

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