Question

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

理想情况下，所述项目负责人只应输入详细信息，并自动生成空缺表格。

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

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

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

我一直在尝试使用我在这里和其他网站上找到的几个宏，但是无法做任何工作，但这个对我来说似乎最符合逻辑/务实 - {{3} }; Our Man In Bananas：

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 ...部分不应包含delete方法，并且需要在粘贴之前激活图表...

像这样：

cqlshrc

导出范围为图像

2 个答案: