Image in Footer via VBA

[toneloke]

Hey guys,

I hope you can assist me... I am trying to protect a document by having a particular footer appear every time a person saves. I have to make multiple versions of the document for different people and am battling to the get the image to change per saved version.

I, by the stroke of luck, got the 1st one to work, but now when I need to change the image in a new version, the original image remains. The text changes but the image does not.

The image is found in the same sheet - if there is a better way to do this, I would also welcome guidance.

I might be a little short on some code to help make this happen. Your kind assistance would be so appreciated.

Here is my code:

Sub Macro1()
With ActiveSheet.PageSetup.RightFooterPicture
.FileName = "Picture 5"
End With
ActiveSheet.PageSetup.RightFooter = "&G"
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
With ws.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "For exclusive use, as the facilitator, by Gatehouse"
.RightFooter = "&G"
End With
Next ws
End Sub

Thank you

 

[Logit]

.
Haven't tested here but ... I am thinking change the name of the image on each page to a unique name relating to that
specific worksheet.

Combing your macros so MACRO1 is included within the Workbook_BeforeSave macro.

 

[toneloke]

Okay... tried that and am debugged the whole time on the .Filename line.

See below - did I forget to add something from previous code?

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
With ActiveSheet.PageSetup.RightFooterPicture
.FileName = "Picture 1"
End With
ActiveSheet.PageSetup.RightFooter = "&G"
With ws.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "For exclusive use, as the facilitator, by Gatehouse"
.RightFooter = "&G"
End With
Next ws
End Sub

I changed the name of the picture to "Gatehouse" and then to "Picture 1" and it gave me the same error - Application Defined or Object Defined error. This feels like it should be easier. SOB.

 

[John_w]

Not totally clear from your posts, but it seems you have a Picture on each sheet and you want each Picture to appear in the sheet's footer when the workbook is saved.

The .FileName property must be the full name of an image file on disk, not the name of a Picture on a worksheet. Therefore you have to save the Picture as a file (e.g. .jpg).

Add this to a standard module:

Public Sub Save_Object_As_Image(saveObject As Object, imageFileName As String, Optional scaleFactor As Single)

    'Save a picture of an object as a JPG/JPEG/GIF/PNG file
    
    'Parameters
    'saveObject     - any object in the CopyPicture method's 'Applies To' list, for example a Range, Shape or Picture
    'imageFileName  - the .gif, .jpg, or .png file name (including folder path if required) the picture will be saved as
    'scaleFactor    - the factor by which the width and height of the object will be scaled in the saved image
    
    Dim temporaryChart As ChartObject
    
    Application.ScreenUpdating = False
        
    saveObject.CopyPicture xlScreen, xlPicture
    
    Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)
    
    With temporaryChart
        .Activate                               'Required, otherwise image is blank
        DoEvents
        .Border.LineStyle = xlLineStyleNone     'No border
        .Chart.Paste
        If scaleFactor > 0 Then
            .Width = .Width * scaleFactor
            .Height = .Height * scaleFactor
        End If
        .Chart.Export imageFileName
        .Delete
    End With
    
    Application.ScreenUpdating = True
    
    Set temporaryChart = Nothing
    
End Sub

And change your Workbook_BeforeSave to:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    Dim ws As Worksheet
    Dim tempImage As String
    
    For Each ws In Worksheets
        tempImage = ThisWorkbook.Path & "\" & ws.Pictures(1).Name & ".jpg"
        Save_Object_As_Image ws.Pictures(1), tempImage
        With ws.PageSetup
            .LeftHeader = ""
            .CenterHeader = ""
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = "For exclusive use, as the facilitator, by Gatehouse"
            .RightFooter = "&G"
            .RightFooterPicture.Filename = tempImage
        End With
        Kill tempImage
    Next ws

End Sub

Note - the above assumes the Picture you want to appear in the footer is the 1st Picture - the ws.Pictures(1) - on each sheet.

 

[toneloke]

I am being told permission denied on the line:
.Chart.Export imageFileName

 

[John_w]

Try changing:

        tempImage = ThisWorkbook.Path & "\" & ws.Pictures(1).Name & ".jpg"

to:

        tempImage = Environ("temp") & "\" & ws.Pictures(1).Name & ".jpg"

 

[toneloke]

Try changing:

        tempImage = ThisWorkbook.Path & "\" & ws.Pictures(1).Name & ".jpg"

to:

        tempImage = Environ("temp") & "\" & ws.Pictures(1).Name & ".jpg"

Thanks so much John, that seems to have worked. YAY! Is it possible to adjust this to apply for print AND save options?

 

[John_w]

Yes, simply repeat the code in the Workbook_BeforePrint handler. Better still, put the code in a new subroutine and call it from Workbook_BeforeSave and Workbook_BeforePrint.

Add this to the standard module:

Public Sub Create_Footers()

    Dim ws As Worksheet
    Dim tempImage As String
    
    For Each ws In Worksheets
        tempImage = Environ("temp") & "\" & ws.Pictures(1).Name & ".jpg"
        Save_Object_As_Image ws.Pictures(1), tempImage
        With ws.PageSetup
            .LeftHeader = ""
            .CenterHeader = ""
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = "For exclusive use, as the facilitator, by Gatehouse"
            .RightFooter = "&G"
            .RightFooterPicture.Filename = tempImage
        End With
        Kill tempImage
    Next ws

End Sub

and put this in the ThisWorkbook module:

Private Sub Workbook_BeforePrint(Cancel As Boolean)
    Create_Footers
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Create_Footers
End Sub

 

[toneloke]

Thanks John...

All seems to be working fabulously... except when I protect the sheet, which I need to do for preventing changes in places that cannot be changed.

I get a bug on Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)

If I unprotect then it works really well, but the minute I protect it causes this error 1004 - Application Defined error.

 

[John_w]

We just need to unprotect and reprotect the sheet, specifying the password (e.g. "123") if you have set one. If you haven't set a password then omit the Password parameter.

Public Sub Save_Object_As_Image(saveObject As Object, imageFileName As String, Optional scaleFactor As Single)

    'Save a picture of an object as a JPG/JPEG/GIF/PNG file
    
    'Parameters
    'saveObject     - any object in the CopyPicture method's 'Applies To' list, for example a Range, Shape or Picture
    'imageFileName  - the .gif, .jpg, or .png file name (including folder path if required) the picture will be saved as
    'scaleFactor    - the factor by which the width and height of the object will be scaled in the saved image
    
    Dim temporaryChart As ChartObject
    
    Application.ScreenUpdating = False
        
    saveObject.CopyPicture xlScreen, xlPicture
    
    ActiveSheet.Unprotect Password:="123"
    
    Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)
    
    With temporaryChart
        .Activate                               'Required, otherwise image is blank
        DoEvents
        .Border.LineStyle = xlLineStyleNone     'No border
        .Chart.Paste
        If scaleFactor > 0 Then
            .Width = .Width * scaleFactor
            .Height = .Height * scaleFactor
        End If
        .Chart.Export imageFileName
        .Delete
    End With
    
    ActiveSheet.Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True
    
    Application.ScreenUpdating = True
    
    Set temporaryChart = Nothing
    
End Sub