VBA save a single group of icons/images/shapes as a picture file.

[drefiek2]

Hi,
I have a sheet called "Handover" with an image of a map and many icons and shapes overlaid, all grouped together which is called "Group 26".
I have an existing working button which saves the whole sheet as a PDF to a location, but I want to add the below code in so everything is done in one button click.
The code should save the group as an image (which ever file format is easiest) into a particular location. Preferably this action should be done before the PDF save action. Overwriting of successive pictures is an essential requirement, and no overwrite warning or message boxes are required.
Any help would be appreciated.

 

[Domenic]

First, add the the following function to your module...

Function ExportShapeToImage(ByVal shapeToExport As Object, ByVal saveAsFileName As String, ByRef errorMessage As String) As Boolean

    On Error GoTo errorHandler
    
    shapeToExport.CopyPicture appearance:=xlScreen, Format:=xlPicture
    
    With shapeToExport.Parent.ChartObjects.Add(Left:=0, Top:=0, Width:=shapeToExport.Width, Height:=shapeToExport.Height)
        .Activate
        With .Chart
            .ChartArea.Format.Line.Visible = msoFalse
            .Paste
            .Export fileName:=saveAsFileName, filtername:="JPG"
        End With
        .Delete
    End With
    
    ExportShapeToImage = True
    
    Exit Function
    
errorHandler:
    errorMessage = "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description
    ExportShapeToImage = False
    
End Function

Then, add the following to your code...

    Dim saveAsFileName As String
    Dim targetShape As Shape
    Dim errorMessage As String
    
    saveAsFileName = "c:\users\username\desktop\sample.jpg" 'change the path and filename accordingly

    Set targetShape = ThisWorkbook.Worksheets("Handover").Shapes("Group 26")
    
    errorMessage = ""
    If Not ExportShapeToImage(targetShape, saveAsFileName, errorMessage) Then
        MsgBox errorMessage, vbCritical
        Exit Sub
    End If

Hope this helps!

 

[drefiek2]

Works perfectly, thanks so much! Always a joy to see ideas working.

First, add the the following function to your module...

Function ExportShapeToImage(ByVal shapeToExport As Object, ByVal saveAsFileName As String, ByRef errorMessage As String) As Boolean

    On Error GoTo errorHandler
   
    shapeToExport.CopyPicture appearance:=xlScreen, Format:=xlPicture
   
    With shapeToExport.Parent.ChartObjects.Add(Left:=0, Top:=0, Width:=shapeToExport.Width, Height:=shapeToExport.Height)
        .Activate
        With .Chart
            .ChartArea.Format.Line.Visible = msoFalse
            .Paste
            .Export fileName:=saveAsFileName, filtername:="JPG"
        End With
        .Delete
    End With
   
    ExportShapeToImage = True
   
    Exit Function
   
errorHandler:
    errorMessage = "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description
    ExportShapeToImage = False
   
End Function

Then, add the following to your code...

    Dim saveAsFileName As String
    Dim targetShape As Shape
    Dim errorMessage As String
   
    saveAsFileName = "c:\users\username\desktop\sample.jpg" 'change the path and filename accordingly

    Set targetShape = ThisWorkbook.Worksheets("Handover").Shapes("Group 26")
   
    errorMessage = ""
    If Not ExportShapeToImage(targetShape, saveAsFileName, errorMessage) Then
        MsgBox errorMessage, vbCritical
        Exit Sub
    End If

Hope this helps!

 

[Domenic]

You're very welcome, I"m glad I could help.

Cheers!