vba 将范围导出为图像
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/43646682/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Export range as image
提问by Snor Neel
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.
在这一点上，我已经自动完成了表单，但我们仍然需要复制范围并将其手动粘贴到油漆中以将其保存为图像。同样在图像的左上角，仍然有一个非常薄的白色左边空间，我们必须调整。
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?
所以我的两个问题是：什么代码能让我成功地实现将范围 (A1:F19) 导出为图像（格式对我来说无关紧要，除非你们看到（dis）任何优点），以及瘦空白得到纠正？
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.
如果图像保存在与执行代码的位置相同的文件夹中并且文件名是单元格 J3 的文件名，那将是理想的。
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?:
我一直在尝试在这里和其他网站上找到的几个宏，但无法进行任何工作，但这对我来说似乎最合乎逻辑/务实 - 归功于我们的香蕉人；使用 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
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.
现在它完美了，除了一个小细节；图像现在有一个（非常非常）细的灰色边框。这并不是一个大问题，只有受过训练的眼睛才会注意到它。如果没有办法摆脱它 - 没什么大不了的。但以防万一，如果你知道一种绝对很棒的方法。
I've tried by changing the values in this line
我已经尝试过更改这一行中的值
Set cob = rng.Parent.ChartObjects.Add(0, 0, 200, 200)
to -10, but that didn't seem to help.
到 -10，但这似乎没有帮助。
回答by Tim Williams
EDIT: 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
回答by Dag
I have been using this a few months, but after upgrading to windows 10 / excel 2016, the export is a blank image. And found that Excel 2016 is a bit slowminded and need everything bit by bit... the with... section should not contain the delete method and the chart need to be activated before paste...
我已经用了几个月了，但升级到 windows 10 / excel 2016 后，导出的是一个空白图像。并发现Excel 2016有点慢，需要一点一点的东西... with...部分不应该包含删除方法并且图表需要在粘贴之前激活...
like this:
像这样：
mychart.Activate
With mychart
.Height = rng.Height
.Width = rng.Width
.Chart.Paste
.Chart.Export Filename:=strTempfile, Filtername:="PNG"
End With
mychart.Delete
