Loop issue to export picture

[Slangy]

Hi all,

I want to export a group of shapes as an image.
The group consists of various shapes that are displayed / hidden based on user selection and show incident types on a map.
All I want is to export this map to a JPG.

I have crafted a script from various finds online, it works sometimes, but it's still not error free.

1. It's updating the timestamp shown on the map
2. selecting the image group (Group 100)
3. pasting it as an image into cell G107
4. creating a chart
5. places the image into the chart
6. Chart is exported as a JPG with a defined file name driven by the user's selection of incident types.
7. The chart and image gets deleted.

The user selection (incident type) is driven by cell E3.

The code runs through all worksheets, which is in fact not required. I will only ever have one chart and one image on this worksheet.

I hope you can guide me spot the mistake I have made.

Sub ExportAllPictures()
    Dim MyChart As Chart
    Dim n As Long, shCount As Long
    Dim Sht As Worksheet
    Dim PictureFileName As String
    Dim PictureNumber As Integer
    Dim PictureName As String
    Dim shp As Shape
    
    ActiveSheet.unprotect
     
    Application.ScreenUpdating = False
    
    PictureFileName = Range("E3")
    PictureName = "Picture"
    PictureNumber = 1
    
    Range("L6").Select
    ActiveCell.FormulaR1C1 = _
        "=CONCATENATE(""As per "",TEXT(NOW(),""dd/mm/yy  hh:mm AM/PM""))"
    
    ActiveSheet.Shapes.Range(Array("Group 100")).Select
    Selection.Copy
    Range("G107").Select
    ActiveSheet.Pictures.Paste.Select
    
  
    For Each Sht In ActiveWorkbook.Sheets
        shCount = Sht.Shapes.Count
        If Not shCount > 0 Then Exit Sub


        For n = 1 To shCount
            If InStr(Sht.Shapes(n).Name, "Picture") > 0 Then
                'create chart as a canvas for saving this picture
                Set MyChart = Charts.Add
                MyChart.Name = "TemporaryPictureChart"
                'move chart to the sheet where the picture is
                Set MyChart = MyChart.Location(Where:=xlLocationAsObject, Name:=Sht.Name)


                'resize chart to picture size
                MyChart.ChartArea.Width = Sht.Shapes(n).Width
                MyChart.ChartArea.Height = Sht.Shapes(n).Height
                MyChart.Parent.Border.LineStyle = 0 'remove shape container border


                'copy picture
                Sht.Shapes(n).Copy


                'paste picture into chart
                MyChart.ChartArea.Select
                MyChart.Paste


                'save chart as jpg
                MyChart.Export Filename:=Sht.Parent.Path & "\NetworkMap - " & PictureFileName & ".jpg", FilterName:="jpg"




                'delete chart
                Sht.Cells(4, 3).Activate
                Sht.ChartObjects(Sht.ChartObjects.Count).Delete
                
                'delete pictures
                For Each shp In ActiveSheet.Shapes
                If shp.Type = msoPicture Then shp.Delete
                Next shp
        
            End If
        Next
    Next Sht
    
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
     
    Application.ScreenUpdating = True
   
     
End Sub

Currently it sometimes errors at
If InStr(Sht.Shapes.Name, "Picture") > 0 Then
with a runtime error: "The index into the specified collection is out of bounds."

It only happens sometimes and I haven't worked out the pattern yet.

I suspect it's because of the Picture name not being found in the loop. Is anyone able to help?

Thank you very much!

 

[Rijnsent]

Hi Slangy,
my hunch is that the picture numbering/indexing is not a neat sequential list (1,2,3,4,etc), but that there is some item skipped/missing. So if you have 4 items with index values (1,2,3,5), you will loop through 1-4 and get an error on number 4 as it doesn't exist.

So try a For Each loop for the Shapes:
For Each Sht In ActiveWorkbook.Sheets
For Each Shp in Sht.Shapes
Next Shp
Next Sht

Hope that helps,
Koen