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
 
Sort by date Sort by votes
Domenic said:
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?
Click to expand...
Domenic,

I would like to be able to print only a selected worksheet, or if possible multiple selected worksheets. The code so far seems to activate the "List Values" sheet to gather the picture, and then prints that page, instead of the prior selected sheets. Is there a way to change the header using the Workbook_BeforePrint function and your code but then reactivate the sheets that were selected prior to printing? (Hopefully this makes since)

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
 
Upvote 0

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Try the following instead...

VBA Code: 
Option Explicit

Private Sub Workbook_BeforePrint(Cancel As Boolean)
    LockHeader
End Sub

Sub LockHeader()

    Application.ScreenUpdating = False
   
    Dim selectedSheets As Sheets
    Set selectedSheets = ActiveWindow.selectedSheets 'remember the selected sheet or sheets
   
    Dim sourceWorksheet As Worksheet
    Set sourceWorksheet = ThisWorkbook.Sheets("List Values")
   
    Dim shp As Shape
    Set shp = sourceWorksheet.Shapes("MyShapeName") 'change the name accordingly
   
    Dim tempFilename As String
    tempFilename = Environ("temp") & "\temp.bmp"
   
    sourceWorksheet.Select 'needed in order to export image
   
    ExportShapeAsBitmap tempFilename, shp
   
    Application.PrintCommunication = False
           
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.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
   
    selectedSheets.Select 'select the sheet or sheets that were originally selected
   
    Application.ScreenUpdating = True

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

Does this help?
 
Upvote 1
Solution
Domenic said:
Try the following instead...

VBA Code: 
Option Explicit

Private Sub Workbook_BeforePrint(Cancel As Boolean)
    LockHeader
End Sub

Sub LockHeader()

    Application.ScreenUpdating = False
  
    Dim selectedSheets As Sheets
    Set selectedSheets = ActiveWindow.selectedSheets 'remember the selected sheet or sheets
  
    Dim sourceWorksheet As Worksheet
    Set sourceWorksheet = ThisWorkbook.Sheets("List Values")
  
    Dim shp As Shape
    Set shp = sourceWorksheet.Shapes("MyShapeName") 'change the name accordingly
  
    Dim tempFilename As String
    tempFilename = Environ("temp") & "\temp.bmp"
  
    sourceWorksheet.Select 'needed in order to export image
  
    ExportShapeAsBitmap tempFilename, shp
  
    Application.PrintCommunication = False
          
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.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
  
    selectedSheets.Select 'select the sheet or sheets that were originally selected
  
    Application.ScreenUpdating = True

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

Does this help?
Click to expand...
So the code works (sorta) ..... but has some weird issues.
1) As written above, only the left and right headers will update, while the code either ignores or skips the center header statement. Also as written, if i manually change the left header and add text, the macro will not replace it with the picture. If I manually edit the right header with text, it is replaced correctly. If I manually edit the left header with a different picture, it is replaced correctly when the macro is run.
2) If I remove the rightheader (third statement) statement from your code above, the left and center header will be updated correctly unless i manually change the left header and add text, the macro will not replace it with the picture.
3) THE CODE WORKS PERFICTLY IN ALL CASES... IF .... I remove the PrintCommunication = False / True statements (but takes forever to run) Why would turning off the printcommunication cause the macro to not work correctly, is this normal?

Thanks for your continued help on this issue!
 
Upvote 0
After doing a quick Google search, it seems that Application.PrintCommunication = False indeed is the culprit. And, unfortunately, I don't have a solution or workaround.

Just curious, though, how long is "forever" ? :)
 
Upvote 0
Domenic said:
After doing a quick Google search, it seems that Application.PrintCommunication = False indeed is the culprit. And, unfortunately, I don't have a solution or workaround.

Just curious, though, how long is "forever" ? :)
Click to expand...
Thanks for confirming the issue with Application.PrintCommunication = False. I will solve the issue by allowing the code you provided to run when the workbook_opens which will set the headers on all sheets. I then made a second sub that will be called when by Workbook_BeforePrint that only runs on the selected sheets. This way I can remove the "Application.PrintCommunication = False" statement without causing too long of a delay in the printing process. Thanks again for your help!
 
Upvote 0
That's great, I'm glad you've found a workaround.

Cheers!
 
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
50
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
267
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,090
Messages
6,123,061
Members
449,091
Latest member
ikke

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