将范围导出为图像

Question

一段时间以来，我和我的同事们一直在使用各种方法来创建一个模板来轻松制作志愿者职位空缺表。

理想情况下，该项目的负责人只需输入详细信息，职位空缺表就会自动生成。

至此，表格已经自动完成了，但我们仍然需要手动复制范围并粘贴到画图中以将其保存为图像。同样在图像的左上角，仍然有一个非常薄的 space 白色左侧，我们必须对其进行调整。

所以我的两个问题：什么代码可以让我成功地实现将范围 (A1:F19) 导出为图像（格式对我来说并不重要，除非你们看到任何（缺点）优势） , 细白 space 得到纠正了吗？

最好将图像保存在与执行代码的文件夹相同的文件夹中，并且文件名是单元格 J3 的文件名。

我一直在尝试在这里和其他网站上找到的几个宏，但无法进行任何工作，但这个对我来说似乎最 logic/pragmatic - 归功于 Our Man In Bananas; Using VBA Code how to export excel worksheets as image in Excel 2003?：

dim sSheetName as string
dim oRangeToCopy as range
Dim oCht As Chart

sSheetName ="Sheet1" ' worksheet to work on
set  oRangeToCopy =Range("B2:H8") ' range to be copied

Worksheets(sSheetName).Range(oRangeToCopy).CopyPicture xlScreen, xlBitmap
set oCht =charts.add

with oCht
    .paste
    .Export FileName:="C:\SavedRange.jpg", Filtername:="JPG"
end with

嗨！感谢您的回答！所以我稍微修改了代码，因为正在创建一个没有扩展名的文件，并且在图像的顶部和左侧留下了一点白色 space。这是结果：

Sub Tester()
    Dim sht As Worksheet
    Set sht = ThisWorkbook.Worksheets("Activiteit")

    ExportRange sht.Range("A1:F19"), _
                ThisWorkbook.Path & "\" & sht.Range("J3").Value & ".png"

End Sub


Sub ExportRange(rng As Range, sPath As String)

    Dim cob, sc

    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    Set cob = rng.Parent.ChartObjects.Add(0, 0, 200, 200)
    'remove any series which may have been auto-added...
    Set sc = cob.Chart.SeriesCollection
    Do While sc.Count > 0
        sc(1).Delete
    Loop

    With cob
        .Height = rng.Height
        .Width = rng.Width
        .Chart.Paste
        .Chart.Export FileName:=sPath, Filtername:="PNG"
        .Delete
    End With

End Sub

现在完美了，除了一个小细节；现在图像周围有一个（非常非常）细的灰色边框。这并不是真正的问题，只有训练有素的眼睛才会注意到它。如果没有办法摆脱它 - 没什么大不了的。但以防万一，如果你知道一个绝对好的方法。

我试过更改此行中的值

Set cob = rng.Parent.ChartObjects.Add(0, 0, 200, 200)

到 -10，但这似乎没有帮助。

Answer 1

编辑：添加了一条线以移除图表对象周围的边框

Sub Tester()
    Dim sht as worksheet
    Set sht = ThisWorkbook.Worksheets("Sheet1")

    ExportRange sht.Range("B2:H8"), _
                ThisWorkbook.Path & "\" & sht.Range("J3").Value

End Sub


Sub ExportRange(rng As Range, sPath As String)

    Dim cob, sc

    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    Set cob = rng.Parent.ChartObjects.Add(10, 10, 200, 200)
    'remove any series which may have been auto-added...
    Set sc = cob.Chart.SeriesCollection
    Do While sc.Count > 0
        sc(1).Delete
    Loop

    With cob
        .ShapeRange.Line.Visible = msoFalse  '<<< remove chart border
        .Height = rng.Height
        .Width = rng.Width
        .Chart.Paste
        .Chart.Export Filename:=sPath, Filtername:="PNG"
        .Delete
    End With

End Sub

Answer 2

我已经用了几个月了，但是升级到 windows 10 / excel 2016 后，导出的是一张空白图像。并且发现Excel 2016有点慢，需要一点一点的... with...部分不应包含删除方法，图表需要在粘贴前激活...

像这样：

mychart.Activate
 With mychart
    .Height = rng.Height
        .Width = rng.Width
        .Chart.Paste
        .Chart.Export Filename:=strTempfile, Filtername:="PNG"      
    End With
mychart.Delete

将范围导出为图像

Export range as image

excel

vba

export

image