image - 将范围导出为图像

Question

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

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

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

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

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

我一直在尝试在这里和其他网站上找到的几个宏，但无法进行任何工作，但这一个对我来说似乎最逻辑/务实 - 归功于 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

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

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