粘贴范围的快照，不失真

我正在使用此代码以png格式将地图从excel导出到位于桌面上的文件夹Mycharts。 但是这个图像在到达指定文件夹时会变形。

Sub ExportMap() Dim day As Integer day = Worksheets("Control").Range("$J$1").Value Worksheets("Map").Range("B2:L43").CopyPicture xlScreen, xlPicture Application.DisplayAlerts = False Set oCht = Charts.Add If day = 1 Then With oCht .Paste .Export Filename:="...\Mycharts\FCT_Day_1.png", filtername:="PNG" .Delete End With End If If day = 2 Then With oCht .Paste .Export Filename:="...\Mycharts\FCT_Day_2.png", filtername:="PNG" .Delete End With End If If day = 3 Then With oCht .Paste .Export Filename:="..\Mycharts\FCT_Day_3.png", filtername:="PNG" .Delete End With End If End Sub 

Answer 1

使用Excel.ChartObject并调整其大小以适应源的像素大小，以避免失真和像素化。

 Sub ExportMap() Dim dy As Integer, pxHeight As Integer, pxWidth As Integer Dim oCht As Excel.ChartObject dy = Worksheets("Control").Range("J1").Value '<~~ J1 is text; it's not going anywhere With Worksheets("Map") With .Range("B2:L43") .CopyPicture xlScreen, xlPicture 'get the dimensions of the screen shot pxHeight = .Height pxWidth = .Width End With Application.DisplayAlerts = False With .ChartObjects.Add(10, 10, pxWidth, pxHeight) Select Case dy Case 1, 2, 3 .Chart.Paste .Chart.Export Filename:=Environ("TMP") & "\FCT_Day_" & dy & ".png", filtername:="PNG" .Delete Case Else 'do nothing End Select End With End With End Sub 

我已经试着收紧你的多个If … Else … End If如果带有Select Case语句，并且将dy （注意：与VBA的本地Day函数名称不同）写入文件名中。