将excel范围另存为图片

abithluo  于 2023-06-25  发布在  其他
关注(0)|答案(4)|浏览(141)

我有一个Excel工作表,其中有几个图表和图像,用作 Jmeter 板。我需要将该区域中的内容保存为图像。我找到了将该区域保存为图像的代码:

Set sht = ActiveWorkbook.Sheets("Graphical Dashboard")
Set strRng = sht.Range("I1:AC124") ' range to be copied

strRng.CopyPicture xlScreen, xlPicture
lWidth = strRng.Width
lHeight = strRng.Height

Set Cht = sht.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
Cht.Activate
Set oCht = Charts.Add

With oCht
    .Paste
    .Export Filename:=ThisWorkbook.Path & "\SavedRange.jpg", Filtername:="JPG"
End With

Cht.Delete

但是,问题是,尽管它保存了与所选范围的区域相匹配的图像,但该图像是空白。此外,它还添加了另一个名为“图表”的工作表,并将空白图像粘贴到工作表中。

djmepvbi

djmepvbi1#

正如你提到的,excel文件已经包含了指定范围内的图表,所以没有必要添加图表对象Set Cht = sht.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
我已经测试了下面的代码,它正在工作。

Private Sub Test()
Set sht = ActiveWorkbook.Sheets("Sheet1")
Set strRng = sht.Range("A1:B2") ' range to be copied
Dim oCht As Chart
strRng.CopyPicture xlScreen, xlPicture
lWidth = strRng.Width
lHeight = strRng.Height
Set oCht = Charts.Add
With oCht
    .Paste
    .Export Filename:="D:\SavedRange.jpg", Filtername:="JPG"
End With
End Sub

如果Excel中没有图表,而你想在VBA中绘制,那么你必须在图表中设置源数据。.SetSourceData Source:=Sheets("Sheet1").Range("A1:B2")

3okqufwl

3okqufwl2#

好吧,做整个事情VBA没有为我工作。因此,我采用了下面的方法。
1.从宏中选择并复制范围。

ActiveWorkbook.Sheets("Graphical Dashboard").Activate
Range("H80:AB121").Select
Selection.Copy

1.将剪贴板中的内容另存为图像。

# invoke the macro
xlapp.Application.Run("SelectRangeMacro")

# save the area as a image
im = ImageGrab.grabclipboard()
im.save('somefile.png','PNG')
qvtsj1bj

qvtsj1bj3#

首先,我选择需要复制的区域并使用方法.CopyPicture,然后如果类型为msoPicture,则从工作簿中清除所有当前图片,然后将图像粘贴到工作表中以将其添加到图表中,然后将复制的图片添加到图表中,导出它,并在完成后删除图表。

Dim oCht, oChtArea, pic
Range("B2:AI5").CopyPicture
'On Error Resume Next

For Each pic In ThisWorkbook.Sheets("MonthlyRevenue").Shapes 'Deleting pics before copying next one in
    If pic.Type = msoPicture Then
        Debug.Print pic.Name
        pic.Delete
    End If
Next

With ThisWorkbook.Sheets("MonthlyRevenue").Pictures.Paste
    .Left = Range("C15").Left
    .Top = Range("C15").Top
    .Name = "monthRevPic"
End With

For Each pic In ThisWorkbook.Sheets("MonthlyRevenue").Shapes
    If pic.Type = msoPicture Then
        Debug.Print pic.Name
        pic.Copy
        'SavePicture pic, "C:\temp\tempchart.jpg"
        Set oCht = ActiveSheet.ChartObjects.Add(0, 0, pic.Width, pic.Height)
        Set oChtArea = oCht.Chart
        With oChtArea
            .Paste
            .Export ("C:\temp\tempchart.jpg")
        End With
        oCht.Delete
    End If
Next
mzmfm0qo

mzmfm0qo4#

我做了这个可移植的功能,在任何情况下都可以工作,并且有一些很酷的功能,比如缩放级别和自动保存为文件对话框:

'Saves a range as image file on disc
' Parameters:
'   * rng = the range to save as image
'   * filename = File path and name of image. If ommited, a save as dialog is used. Accepted formats: .JPG, .BMP and .GIF. OPTIONAL.
'   * Zoom = Zoom to apply to the image before saving. Example: Zoom of 200 will make image twice the actual size.
' Returns: True = success
'
Public Function Save_Range_snapshot_as_image(rng As Range, Optional filename As String = "", Optional Zoom As Double = 100) As Boolean
  Dim ws As Worksheet
  Dim ChO As ChartObject
  Dim OldZoom As Single
    
    'Setup
    On Error GoTo ErrorCatch
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set ws = rng.Worksheet
    ws.Activate
    OldZoom = ActiveWindow.Zoom
    ActiveWindow.Zoom = Zoom
    
    'Create temporary chart
    rng.CopyPicture xlScreen, xlPicture
    Set ChO = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=WorksheetFunction.Min(rng.Width + 100, 169056), Height:=rng.Height + 100)
    ChO.Activate
    With ChO.Chart
        .parent.Border.LineStyle = 0
        .Paste
        .ChartArea.Width = .Shapes(1).Width - 6
        .ChartArea.Height = .Shapes(1).Height - 6
        .Shapes(1).ScaleWidth 1, msoTrue
    End With
    
    'Save chart image to file
    If filename = "" Then
    filename = Application.GetSaveAsFilename(fileFilter:="Portable Networks Graphic (*.png),*.png, JPEG (*.jpg),*.jpg, Bitmap (*.bmp), *.bmp, GIF (*.gif), *.gif,")
        If CStr(filename) = CStr(False) Then GoTo cancel
    End If
    If ChO.Chart.Export(filename) Then Save_Range_snapshot_as_image = True

cancel:
    'Clean up
    On Error Resume Next
    ChO.Delete
    ActiveWindow.Zoom = OldZoom
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Function
ErrorCatch:
    If Err.Number = 1004 Then Resume Else Stop  'Unhandled Error occured
End Function

相关问题