Loop issue to export picture

Slangy

New Member
Joined
Oct 22, 2019
Messages
3
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.

Code:
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(n).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

Well-known Member
Joined
Oct 17, 2005
Messages
1,153
Office Version
365
Platform
Windows
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
 

Forum statistics

Threads
1,082,144
Messages
5,363,381
Members
400,732
Latest member
robcooper2001

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top