Sub ExporterShapesChartsEtPicturesOK()
Dim fname$, shp As Shape
If Len(ActiveWorkbook.Path) > 0 Then
fname = ActiveWorkbook.Path & "\"
End If
If TypeName(Selection) = "DrawingObjects" Then
For Each shp In Selection.ShapeRange
Select Case shp.Type
Case 1, 13
'autoshape, picture
If shp.Type = 1 Then
If Len(shp.DrawingObject.Formula) > 0 Then
shp.TextFrame2.TextRange.Characters.Text = ActiveSheet.Range(CStr(shp.DrawingObject.Formula)).Text
shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
shp.DrawingObject.Formula = vbNullString
End If
End If
shp.CopyPicture
ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Name = "x_" & shp.Name
With ActiveSheet.ChartObjects("x_" & shp.Name)
.Chart.Paste
.Chart.Export fname & "x_" & shp.Name & ".png"
.Delete
End With
Case 3
'charts
ActiveSheet.ChartObjects(shp.Name).Chart.Export fname & shp.Name & ".png"
End Select
Next shp
End If
End Sub