Adding a picture (found on worksheet) to Header using VBA in Private Sub

R

rjheibel

New Member
Joined
Mar 8, 2018
Messages
42
I want to add a picture to the left header on all sheets within a workbook. I pasted the picture in a sheet "List Values". I currently am using the code below. what code do I need to add to accomplish this. I've tried modifying this with code I found on other threads but have not been able to get it to work. Thanks!


VBA Code: 
Private Sub Workbook_BeforePrint(Cancel As Boolean)
    Call LockHeader
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Call LockHeader
End Sub


Private Sub LockHeader()

    Application.ScreenUpdating = False
    
    Sheets("List Values").Select
            
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.PageSetup.CenterHeader = "&""-,Bold""&18" & " " & ActiveSheet.Range("E1").Value
        ws.PageSetup.RightHeader = "&""-,Bold""&18" & " " & ActiveSheet.Range("F1").Value
    Next ws

    Application.ScreenUpdating = True
End Sub
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Sort by date Sort by votes
Try the following...

VBA Code: 
Private Sub LockHeader()

    Application.ScreenUpdating = False
  
    'group all worksheets within the active workbook
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.Select Replace:=False
    Next ws
  
    'turn off communication with the printer to speed execution of code that sets PageSetup properties
    Application.PrintCommunication = False
  
    With ActiveSheet.PageSetup
        .LeftHeaderPicture.Filename = "c:\users\domta\pictures\sample.png" 'change the path and filename accordingly
        .LeftHeader = "&G"
    End With
  
    'turn back on communication with the printer to commit all cached PageSetup settings
    Application.PrintCommunication = True
  
    Sheets("List Values").Select
          
    Application.ScreenUpdating = True
  
End Sub

Hope this helps!
 
Upvote 0
How would i do this with a picture that is within the file? As this file will be used by other people, i dont want the picture tied to a file location on my comp.
 
Upvote 0
rjheibel said:
How would i do this with a picture that is within the file? As this file will be used by other people, i dont want the picture tied to a file location on my comp.
Click to expand...
www.mrexcel.com

Adding Picture from worksheet to Header (VBA)

Hi, I'm Trying to add a picture from the worksheet (Picture 1) to the header and I'm getting a Run-time error '438' Object doesn't support this property or method. The error happens on this line ActiveSheet.PageSetup.CenterHeaderPicture = ActiveSheet.Shapes.Range(Array("Picture 1")) Thanks...
www.mrexcel.com www.mrexcel.com
 
Upvote 0
Yes, I have seen that post, but have not been able to get it to do what I want. I would like the logo that I pasted onto the "List Values" page, to be added as the header to each sheet in the workbook. I have done this with text that pulls from cells from the same sheet, but need help with modifying the code below to allow the logo to be pulled into the left header.

VBA Code: 
    Application.ScreenUpdating = False
    
    Sheets("List Values").Select
            
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.PageSetup.CenterHeader = "&""-,Bold""&18" & " " & ActiveSheet.Range("E1").Value
        ws.PageSetup.RightHeader = "&""-,Bold""&18" & " " & ActiveSheet.Range("F1").Value
    Next ws

    Application.ScreenUpdating = True
 
Upvote 0
Okay, I have made a couple of assumptions...

1) You don't want the headers (left, centre, and right) added to your "List Values" worksheet.

2) The values for the centre and right headers are located in cells E1 and F1, respectively, on your "List Values" worksheet.

If these assumptions are incorrect, you can always make the necessary corrections. Accordingly, first add the following procedure to your code module...

VBA Code: 
Sub ExportShapeAsBitmap(ByVal saveAsFilename As String, ByVal shapeToExport As Object)

    shapeToExport.CopyPicture appearance:=xlScreen, Format:=xlBitmap 'Picture copied in bitmap (raster) format: bmp, jpg, gif, png
 
    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
        End With
        .Delete
    End With
 
End Sub

Then try the following code. Note that you'll need to change the name of your picture where specified in the code.

VBA Code: 
    Application.ScreenUpdating = False
 
    Dim sourceWorksheet As Worksheet
    Set sourceWorksheet = ThisWorkbook.Sheets("List Values")
 
    Dim shp As Shape
    Set shp = sourceWorksheet.Shapes("MyPictureName") 'change the name accordingly
 
    Dim tempFilename As String
    tempFilename = Environ("temp") & "\temp.bmp"
 
    ExportShapeAsBitmap tempFilename, shp
 
    Application.PrintCommunication = False
         
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> sourceWorksheet.Name Then
            With ws.PageSetup
                .LeftHeaderPicture.Filename = tempFilename
                .LeftHeader = "&G"
                .CenterHeader = "&""-,Bold""&18" & " " & sourceWorksheet.Range("E1").Value
                .RightHeader = "&""-,Bold""&18" & " " & sourceWorksheet.Range("F1").Value
            End With
        End If
    Next ws
 
    Application.PrintCommunication = True
 
    Kill tempFilename

    Application.ScreenUpdating = True

Hope this helps!
 
Upvote 0
Domenic said:
Okay, I have made a couple of assumptions...

1) You don't want the headers (left, centre, and right) added to your "List Values" worksheet.

2) The values for the centre and right headers are located in cells E1 and F1, respectively, on your "List Values" worksheet.

If these assumptions are incorrect, you can always make the necessary corrections. Accordingly, first add the following procedure to your code module...

VBA Code: 
Sub ExportShapeAsBitmap(ByVal saveAsFilename As String, ByVal shapeToExport As Object)

    shapeToExport.CopyPicture appearance:=xlScreen, Format:=xlBitmap 'Picture copied in bitmap (raster) format: bmp, jpg, gif, png
 
    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
        End With
        .Delete
    End With
 
End Sub

Then try the following code. Note that you'll need to change the name of your picture where specified in the code.

VBA Code: 
    Application.ScreenUpdating = False
 
    Dim sourceWorksheet As Worksheet
    Set sourceWorksheet = ThisWorkbook.Sheets("List Values")
 
    Dim shp As Shape
    Set shp = sourceWorksheet.Shapes("MyPictureName") 'change the name accordingly
 
    Dim tempFilename As String
    tempFilename = Environ("temp") & "\temp.bmp"
 
    ExportShapeAsBitmap tempFilename, shp
 
    Application.PrintCommunication = False
        
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> sourceWorksheet.Name Then
            With ws.PageSetup
                .LeftHeaderPicture.Filename = tempFilename
                .LeftHeader = "&G"
                .CenterHeader = "&""-,Bold""&18" & " " & sourceWorksheet.Range("E1").Value
                .RightHeader = "&""-,Bold""&18" & " " & sourceWorksheet.Range("F1").Value
            End With
        End If
    Next ws
 
    Application.PrintCommunication = True
 
    Kill tempFilename

    Application.ScreenUpdating = True

Hope this helps!
Click to expand...
Domenic,
Thanks for your reply! Your code works in adding the image to the header, but when I go to print any sheet in the workbook, it only prints the "List Values" sheet. I believe this is due to me calling on this code with the Workbook_BeforePrint command. This was done to prevent the headers from being changed. What needs to be changed to print the active worksheet / worksheets, instead of the List Value sheet?

VBA Code: 
Private Sub Workbook_BeforePrint(Cancel As Boolean)
    Call LockHeader
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Call LockHeader
End Sub

Sub ExportShapeAsBitmap(ByVal saveAsFilename As String, ByVal shapeToExport As Object)

    shapeToExport.CopyPicture appearance:=xlScreen, Format:=xlBitmap 'Picture copied in bitmap (raster) format: bmp, jpg, gif, png
    
    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
        End With
        .Delete
    End With
    
End Sub


Private Sub LockHeader()

    Application.ScreenUpdating = False
    
    Dim sourceWorksheet As Worksheet
    Set sourceWorksheet = ThisWorkbook.Sheets("List Values")
    
    Dim shp As Shape
    Set shp = sourceWorksheet.Shapes("Picture1") 'change the name accordingly
    
    Dim tempFilename As String
    tempFilename = Environ("temp") & "\temp.bmp"
    
    ExportShapeAsBitmap tempFilename, shp
    
    Application.PrintCommunication = False
            
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> sourceWorksheet.Name Then
            With ws.PageSetup
                .LeftHeaderPicture.Filename = tempFilename
                .LeftHeader = "&G"
                .CenterHeader = "&""-,Bold""&18" & " " & sourceWorksheet.Range("E1").Value
                .RightHeader = "&""-,Bold""&18" & " " & sourceWorksheet.Range("F1").Value
            End With
        End If
    Next ws
    
    Application.PrintCommunication = True
    
    Kill tempFilename

    Application.ScreenUpdating = True
End Sub
 
Upvote 0
I believe this is due to me calling on this code with the Workbook_BeforePrint command.
Click to expand...

How are you "calling on this code..." ?
 
Upvote 0
Domenic said:
How are you "calling on this code..." ?
Click to expand...
I am using the code below. The code I posted above has everything in relation to locking the header. When I go to print, it changes the header on the sheets correctly, but then prints only the List Values page.

VBA Code: 
Private Sub Workbook_BeforePrint(Cancel As Boolean)
    Call LockHeader
End Sub
 
Upvote 0
Oh I see, when you said "calling on this code" I thought you meant you were using code to print and call the BeforePrint event. When you want to manually print all sheets within your workbook, make sure that you choose the option "Print Entire Workbook" . . .

VBA Code: 
File >> Print >> Settings > click the drop down, and select Print Entire Workbook

Does this help?
 
Upvote 0
You must log in or register to reply here.

Similar threads

TAPS_MikeDion
  • Solved
Use VBA to add year to header for all sheets
Replies
5
Views
59
Joe4
Joe4
VinceF
  • Solved
Combine 2 VBA Script's to 1 Command Button
Replies
3
Views
136
Candyman8019
C
H
  • Solved
Private sub to generate Text
Replies
5
Views
185
mumps
mumps
myall_blues
  • Solved
VBA form OK_click not returning to calling Sub
Replies
7
Views
274
RoryA
RoryA
L
  • Question
VBA to autosave and close after a set amount of time
Replies
3
Views
131
Anthony47
A

Forum statistics

Threads
1,215,096
Messages
6,123,074
Members
449,093
Latest member
ripvw

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top