从 Excel 2012 导出一组图形对象（图表和其他线条）

Question

我有 VBA 代码，可以从 Excel 以 PNG 格式导出活动图表。

我有一些点和线，标记了一些覆盖在我的 Excel 图表上的重要数据，并且它们被分组（选择所有对象和图表，右键单击 -> 分组）。

有什么可以替换 ActiveChart 的东西（如 ActiveGroup 或类似的）来导出整个内容，而不仅仅是图表。

Sub ExportChartToPNG()
'Take ActiveChart and copy it as a GIF image to the same directory as the Workbook is in and name it with the Chart_Title with spaces replaced with underscores.
Dim chtCopyChart As Chart, sCurrentDirectory As String, sFileName As String
Dim x As Integer, CellCharacter As String
Dim sInteractive As Boolean

Set chtCopyChart = ActiveChart
sCurrentDirectory = ActiveWorkbook.Path
sFileName = chtCopyChart.ChartTitle.Text
sFileName = InputBox("Enter filename for export:", "Export object", sFileName)

For x = 1 To Len(sFileName)
    CellCharacter = Mid(sFileName, x, 1)
    If CellCharacter Like "[</*\?%]" Then
        sFileName = Replace(sFileName, CellCharacter, "_", 1) ', Replaces all illegal filename characters with "_"
    End If
If Asc(CellCharacter) <= 32 Then
    sFileName = Replace(sFileName, CellCharacter, "_", 1) ' Replaces all non printable characters with "_"
End If

Next

sFileName = sFileName & ".png"
sFileName = sCurrentDirectory & "\" & sFileName
sInteractive = True

chtCopyChart.Export Filename:=sFileName, FilterName:="PNG", Interactive:=sInteractive

MsgBox "Chart copied to " & sFileName, vbOKOnly, "Success!"

End Sub

Answer 1

我知道这个老问题，但解决方案来自这样一个事实：与其他形状分组的图表成为工作表中的形状对象。因此，您实际上需要做的是获取对形状对象的引用，该形状对象是您创建的组。

但是，形状没有导出方法，因此您需要创建一个临时空白图表，将形状复制到其中，导出新图表，然后将其删除。

步骤如下：

获取形状对象并将其复制为图片

set myshape = Sheet24.Shapes("shapename")
myshape.CopyPicture

创建一个与源形状尺寸相同的新图表对象

 set chtObj = Sheets24.ChartObjects.Add(myshape.Left, myshape.Top, myshape.Width, myshape.height)

将对象从剪贴板粘贴到新图表

chtObj.Chart.Paste

导出图表，如果需要，删除现有文件

Kill fullpathandfilename    
chtObj.Chart.Export filename:=fullpathandfilename, Filtername:="PNG" 

然后删除图表并清理物体。

chtObj.Delete
Set chtObj = nothing

Answer 2

下面的代码用于保存一组形状的图像。这是对杰里米答案的修改，它找到一个特定的组（基于“格式形状”下找到的[替代文本]标题）。子程序首先运行特定的宏（以更新组中的图形）。

Global Const myFilePath = "C:\YourFolder\"    
Public Sub saveChart(ByVal sheetName As String, ByVal macroName As String, _
                            ByVal fileName As String, exportType As Integer)
        Dim wb As Workbook
        Dim ws As Worksheet
        Set wb = ThisWorkbook
        Set ws = Sheets(sheetName)
        ws.Activate
        Application.Run "'" & wb.Name & "'!VBAProject." & ws.CodeName & "." & macroName

        Select Case exportType
            Case 0 'standard chart
                Set objChrt = Sheets(sheetName).ChartObjects(1)
                Set myChart = objChrt.Chart
                myChart.Export fileName:=myFilePath & fileName, Filtername:="JPEG"
            Case 1 'Group of chart and other objects
                Dim sh As Shape
                Dim I As Integer
                Dim groupedName As String
                I = 1
                    'Find grouped shape in worksheet with Title of 'Export'
                For Each sh In ActiveSheet.Shapes
                    If sh.Type = 6 Then '6 indicates it's a group
                        If sh.Title = "Export" Then
                            Set myshape = sh
                            groupedName = sh.Name
                        End If
                    End If
                    I = I + 1
                Next
                    'Select and copy group
                ws.Shapes.Range(Array(groupedName)).Select
                Selection.CopyPicture
                    'Create temporary chart
                Set chtObj = ws.ChartObjects.Add( _
                            myshape.Left, myshape.Top, myshape.Width, myshape.Height)
                    'Select temporary chart and paste the Group
                chtObj.Select
                chtObj.Chart.Paste
                    'Export the image
                chtObj.Chart.Export fileName:=myFilePath & fileName, Filtername:="JPEG"
                    'Clean up
                chtObj.delete
                Set chtObj = Nothing
            Case Else
        End Select
        Set wb = Nothing
        Set ws = Nothing
    End Sub