如何防止因DPI更改而导致缩放？

Question

我在Powerpoint VBA宏中使用Shapes.AddOLEObject Powerpoint功能，当[显示图表]按钮显示时，将Excel图表文件（扩展名：.xls）显示到powerpoint幻灯片上点击。

Set shapeOnPPT = 
ActivePresentation.Slides.FindBySlideID(mySlideID).Shapes.AddOLEObject(Left:=100,_
Top:=100, Width:=500, Height:=400, FileName:="c:\ThisDoc\testing.xls", Link:=msoTrue)

问题

更改计算机显示器的DPI /分辨率并单击[显示图表]按钮后，新图表将缩小/展开，如下所示

解决方法

我必须退出并重新登录才能刷新＆＃39; Excel图表缩放到100％。

问题

如何解决此问题？每次更改电脑的分辨率/ DPI时，我都不想签名/登录。

Answer 1

您可以使用User32库中的GetSystemMetrics来获取当前的屏幕分辨率，然后根据您设计文件的原始屏幕分辨率，将倍增器应用于图表大小的问题。将下面的代码中的sWOrig和sHOrig更改为正确的分辨率。

Declare Function GetSystemMetrics32 Lib "User32" _
Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long

Sub SizeChart()

Dim sW As Long, sH As Long
Dim sWOrig As Long, sHOrig As Long
Dim cW As Double, cH As Double
Dim wMulti As Double, hMulti As Double

sWOrig = 1920
sHOrig = 1080

sW = GetSystemMetrics32(0) ' screen resolution width in points
sH = GetSystemMetrics32(1) ' screen resolution height in points

wMulti = sW / sWOrig
hMulti = sH / sHOrig

cW = 500 * wMulti
sH = 400 * hMulti

Set test = ActivePresentation.Slides(1)
test.Shapes.AddOLEObject Left:=100, Top:=100, _
Width:=cW, Height:=sH, _
FileName:="c:\ThisDoc\testing.xls"

End Sub