使用 VBA 从 Excel 复制单元格以用作图像

Question

我在 Excel-VBA 中使用以下代码复制单元格区域并将其粘贴为保存的图像，然后显示在用户表单上。 它“有效”，但我遇到的问题是正在创建的对象大小不正确。 它使我的图像看起来被压扁和扭曲。 如何修改它以便我的图像粘贴到对象中而没有任何调整大小的问题？ 我找到了很多关于如何执行保存图像的初始部分的答案，但没有找到关于如何修改我粘贴到的图表或对象的大小的答案。

Dim k As Integer
Dim intCount As Integer
Dim objPic As Shape
Dim objChart As Chart
'copy the range as an image
Call Sheet3.Range(Cells(49, 13), Cells(51 + t - 1, 14)).CopyPicture(xlScreen, xlPicture)
''the minus 1 here means we are not seeing total cost on our item list right now.

'remove all previous shapes in sheet2
intCount = Sheet2.Shapes.Count
For k = 1 To intCount
Sheet2.Shapes.Item(1).Delete
Next k
'create an empty chart in sheet2
Sheet2.Shapes.AddChart
'activate sheet2
Sheet2.Activate
'select the shape in sheet2
Sheet2.Shapes.Item(1).Select
Set objChart = ActiveChart
'paste the range into the chart
objChart.Paste
'save the chart as a JPEG
objChart.Export ("C:\StuffBusinessTempExample.Jpg")


'Sets image to be the quote
Image1.Picture = LoadPicture("C:/StuffBusinessTempExample.jpg")

Answer 1

像这样的东西：

Sub tester()
    ExportRange Selection, "C:\_Stuff\Temp\Example3.Jpg"
    ExportRange ActiveSheet.Range("A2:F11"), "C:\_Stuff\Temp\Example4.Jpg"
End Sub


Sub ExportRange(rng As Range, fPath As String)

    rng.CopyPicture xlScreen, xlPicture
    With ActiveSheet.Shapes.AddChart
        'remove any data from the chart
        Do While .Chart.SeriesCollection.Count > 0
            .Chart.SeriesCollection(1).Delete
        Loop
        'resize to match the range
        .Height = rng.Height
        .Width = rng.Width
        .Chart.Paste
        .Chart.Export fPath
        .Delete
    End With

End Sub

Answer 2

您不需要将范围保存为图片，您可以将其直接从剪贴板粘贴到工作表上：

Call Range(Cells(49, 13), Cells(51 + t - 1, 14)).Copy
''the minus 1 here means we are not seeing total cost on our item list right now.

'' Do all your other stuff here

ActiveSheet.Pictures.Paste.Select