Insert a image as footer on multiple sheets based on a reference from Sheet1?

[paddingtonbear]

I have a workbook with scripts/modules. And running through many of them with the logic of:

For Each sh In Worksheets
If sh.Name <> ..... etc
ActiveSheet.PageSetup.CenterFooter = "& "&N" or whatever i need on each sheet.
I am excluding Sheet1 from the 'loop'. But on Sheet1 i have a image called "Image 10" (i figure this is called in term "Box Name")? which is located at A11-A14 and E11-E14


How could i add this particular image to my loop which would result that the image appears in footer on each sheet? and resize it as following:

based on the values from Footer Settings:
footer: &[image]
:
Height 2.82 inch
Width 14.18 inch
scale: 393% 394%
locked image to reference [x]

Tried searching around but cant figure it out. And this forum has helped me so much in my VBA learning process,
Thanks to every user and poster on here

 

[Domenic]

The code would first need to export the worksheet picture to your local drive, and then it could be assigned to a footer. So, for example, the following code first exports the picture to the temporary folder on your local drive, then it assigns the picture to the footers for each worksheet, except Sheet1, and then deletes the exported picture from the temporary folder.

Sub AddFooterPictureToSheets()

    Dim imageWorksheet As Worksheet
    Set imageWorksheet = ThisWorkbook.Worksheets("Sheet1")
   
    Dim image As Picture
    Set image = imageWorksheet.Pictures("Image 10")
   
    Dim tempFileName As String
    tempFileName = Environ("temp") & "\temp.jpg"
   
    Dim errorMessage As String
    errorMessage = ""
   
    If Not ExportShapeToImage(image, tempFileName, errorMessage) Then
        MsgBox errorMessage, vbCritical, "Error"
        Exit Sub
    End If
   
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> imageWorksheet.Name Then
            With ws.PageSetup
                With .CenterFooterPicture
                    .Filename = tempFileName
                    .LockAspectRatio = msoFalse
                    .Width = Application.InchesToPoints(2.3) 'change as desired
                    .Height = Application.InchesToPoints(0.45) 'change as desired
                    .LockAspectRatio = msoTrue
                End With
                .CenterFooter = "&G"
            End With
        End If
    Next ws
   
    Kill tempFileName
   
End Sub

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:=xlBitmap
 
    Dim tempWorksheet As Worksheet
    Set tempWorksheet = ThisWorkbook.Worksheets.Add
 
    With tempWorksheet.ChartObjects.Add(Left:=0, Top:=0, Width:=shapeToExport.Width, Height:=shapeToExport.Height)
        .Activate
        With .Chart
            .ChartArea.Format.Line.Visible = msoFalse
            .Paste
            .Export Filename:=saveAsFileName
        End With
        '.Delete
    End With
 
    Application.DisplayAlerts = False
    tempWorksheet.Delete
    Application.DisplayAlerts = True
 
    ExportShapeToImage = True
 
    Exit Function
 
errorHandler:
    errorMessage = "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description
    ExportShapeToImage = False
 
End Function

Hope this helps!

 

[paddingtonbear]

The code would first need to export the worksheet picture to your local drive, and then it could be assigned to a footer. So, for example, the following code first exports the picture to the temporary folder on your local drive, then it assigns the picture to the footers for each worksheet, except Sheet1, and then deletes the exported picture from the temporary folder.

Sub AddFooterPictureToSheets()

    Dim imageWorksheet As Worksheet
    Set imageWorksheet = ThisWorkbook.Worksheets("Sheet1")
  
    Dim image As Picture
    Set image = imageWorksheet.Pictures("Image 10")
  
    Dim tempFileName As String
    tempFileName = Environ("temp") & "\temp.jpg"
  
    Dim errorMessage As String
    errorMessage = ""
  
    If Not ExportShapeToImage(image, tempFileName, errorMessage) Then
        MsgBox errorMessage, vbCritical, "Error"
        Exit Sub
    End If
  
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> imageWorksheet.Name Then
            With ws.PageSetup
                With .CenterFooterPicture
                    .Filename = tempFileName
                    .LockAspectRatio = msoFalse
                    .Width = Application.InchesToPoints(2.3) 'change as desired
                    .Height = Application.InchesToPoints(0.45) 'change as desired
                    .LockAspectRatio = msoTrue
                End With
                .CenterFooter = "&G"
            End With
        End If
    Next ws
  
    Kill tempFileName
  
End Sub

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:=xlBitmap
 
    Dim tempWorksheet As Worksheet
    Set tempWorksheet = ThisWorkbook.Worksheets.Add
 
    With tempWorksheet.ChartObjects.Add(Left:=0, Top:=0, Width:=shapeToExport.Width, Height:=shapeToExport.Height)
        .Activate
        With .Chart
            .ChartArea.Format.Line.Visible = msoFalse
            .Paste
            .Export Filename:=saveAsFileName
        End With
        '.Delete
    End With
 
    Application.DisplayAlerts = False
    tempWorksheet.Delete
    Application.DisplayAlerts = True
 
    ExportShapeToImage = True
 
    Exit Function
 
errorHandler:
    errorMessage = "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description
    ExportShapeToImage = False
 
End Function

Hope this helps!

Thank you very much @Domenic for your response and for all help.
This worked perfect. I just needed my own values and added some spacing in the image footer to be more centered. Included it inside one of my modules and worked perfect.

Credited you in my Excel VBA project im working on.

 

[Domenic]

That's great, I'm glad you were able to get it the way you want.

Cheers!