导出范围为图像 [英] Export range as image

问题描述

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

For a while now, my colleagues and me have been using all kinds of methods to create a template to easily make volunteer vacancy forms.

理想情况下，所述项目的费用应该只输入详细信息，并且空缺表格会自动生成。

Ideally, the person in charge of said project should only input details and the vacancy form is generated automatically.

此时，我已经自动完成表格，但我们仍然有复制范围并手动将其粘贴到油漆中以将其另存为图像。同样在图像的左上角，还有一个非常薄的白色空间我们必须调整。

At this point, I got as far as having the form completed automatically, but we still have to copy the range and paste it into paint manually to save it as an image. Also at the top en left side of the image, there's still a very thin space of white left that we have to adjust.

所以我的两个问题：代码会带来什么我成功地实现了输出范围（A1：F19）作为图像（格式对我来说无关紧要，除非你们看到（dis）任何优点），并且薄白空间得到纠正？

So my two questions: what code will bring me succes in achieving both the exporting a range (A1:F19) as image (format doesn't matter to me, unless you guys see (dis)advantages in any), and that the thin white space gets corrected?

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

It would be ideal if the image would be saved in the same folder as from where the code is being executed and the file name would be that of cell J3.

我一直在尝试我在这里和其他网站上发现的几个宏，但是无法做任何工作，但这个对我来说似乎最符合逻辑/实用 - 相信我们的香蕉男士; 使用VBA如何在Excel 2003中将Excel工作表导出为图像？：

I've been trying several macro's I found both here and on other sites, but was unable to make any work, but this one seemed most logic/pragmatic to me - credits to 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

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

Hi! thanks for your answer! So I altered the code slightly, because a file without extension was beaing created, and a little bit of white space was left at the top and left of the image. This is the result:

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

现在除了一个小细节之外它是完美的;图像现在周围有一个（非常非常）薄的灰色边框。它不是那么大，它确实是一个问题，只有训练有素的眼睛会注意到它。如果没有办法摆脱它 - 没什么大不了的。但为了以防万一，如果你知道一种非常棒的方式。

Now it's perfect except for one small details; the image now has a (very, very) thin gray border around it. It's not that big that it's really an issue, only trained eyes would notice it. If there's no way to get rid of it - no biggie. But just in case, if you'd know a way that would be absolutely great.

我试过改变这一行的值

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

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

to -10, but that didn't seem to help.

推荐答案

编辑：添加一行以删除图表对象周围的边框

added a line to remove the border from around the chartobject

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

这篇关于导出范围为图像的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！