导出范围为图片

Question

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

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

在这一点上，我尽可能自动完成表格，但我们仍然必须复制范围并手动将其粘贴到绘图中以将其保存为图像。同样在图像的顶部左侧，还有一个非常薄的白色左侧空间，我们必须调整。所以我的两个问题：什么代码会使我成功实现将范围（A1：F19）导出为图像（格式对我无关紧要，除非你们在任何方面看到（dis）优点），而薄的白色空间得到纠正？

如果将图像保存在与执行代码相同的文件夹中，并且文件名将是单元格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 

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

我已经在这一行

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

-10更改值尝试过，但似乎并没有帮助。

Answer 1

编辑：添加了一行到来自各地的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