将范围导出为图像

Question

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

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

此时，我已经可以自动完成表单了，但是我们仍然需要复制范围并将其手动粘贴到 Paint 中以将其另存为图像。另外，在图像的顶部和左侧，仍然有一个非常薄的白色左侧空间，我们必须调整。

所以我的两个问题：什么代码能让我成功实现将范围（A1：F19）导出为图像（格式对我来说并不重要，除非你们看到任何优点），并且细小的空白得到纠正？

如果将图像保存在与执行代码的文件夹相同的文件夹中并且文件名是单元格 J3 的文件名，那将是理想的选择。

我一直在尝试在这里和其他网站上找到的几个宏，但无法做出任何工作，但这一个对我来说似乎最逻辑/务实 - 归功于我们的香蕉人； 使用VBA代码如何在Excel 2003中将Excel工作表导出为图像？:

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

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

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