Использование 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