Sub to load a custom header and footer

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,147
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have a sub that is meant to load a custom header and footer

VBA Code:
Sub Wes_header_footer()
Dim printWorksheet As Worksheet, logoShape As Shape, tempImageFile As String
Dim footshape As Shape, ACAWorksheet As Worksheet

        'The worksheet on which the print page setup will apply
        Set printWorksheet = ThisWorkbook.Worksheets("CSS_quote_sheet")
        'Set ACAWorksheet = ThisWorkbook.Worksheets("ACA_Quoting")
        'The sheet location and name of shape to be used in page setup
            
        Set logoShape = ThisWorkbook.Worksheets("sheet2").Shapes("ImgWestHeader")
        Set footshape = ThisWorkbook.Worksheets("sheet2").Shapes("ImgWestFooter")

        'Save the shape as a temporary image
        tempImageFile = Environ("temp") & "\image.jpg"
        Save_Object_As_Picture logoShape, tempImageFile
            With printWorksheet.PageSetup
                .CenterHeaderPicture.fileName = tempImageFile
                .CenterHeader = "&G"
            End With
        Kill tempImageFile
        
        tempImageFile = Environ("temp") & "\image.jpg"
        Save_Object_As_Picture footshape, tempImageFile
            With printWorksheet.PageSetup
                .CenterFooterPicture.fileName = tempImageFile
                .CenterFooter = "&G"
            End With
        Kill tempImageFile
        

        
    Worksheets("CSS_quote_sheet").Activate
    Range("B7").Value = "Ang Wes"
        
End Sub


And also, part of the same module
VBA Code:
Private Sub Save_Object_As_Picture(saveObject As Object, imageFileName As String)
    Dim temporaryChart As ChartObject
    Application.ScreenUpdating = False
    saveObject.CopyPicture xlScreen, xlPicture
    Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width + 1, saveObject.Height + 1)
    With temporaryChart
        .Activate
        .border.LineStyle = xlLineStyleNone      'No border
        .Chart.Paste
        .Chart.Export imageFileName
        .Delete
    End With
    Application.ScreenUpdating = True
    Set temporaryChart = Nothing
End Sub


It used to work fine so I have no idea why it isn't working now.


I try to run it now and I get the error of Application defined or object defined error. I press debug and this line in the second procedure is highlighted:
VBA Code:
Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width + 1, saveObject.Height + 1)

Could someone help me work out the problem please?
 

Some videos you may like

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,168
Office Version
  1. 2016
Platform
  1. Windows
Do a search for OleCreatePictureIndirect to see how you can create a StdPicture object from the shapes.
 

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,147
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Thanks for that but I am not quite that advanced yet in my coding understanding and am having trouble understanding the resulting hits. I copied the code from somewhere so I do not really know how it works.
 

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,147
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I used the macro recorder to record a macro that gave this code:

VBA Code:
    Sheets("Sheet2").Shapes.Range(Array("ImgL")).Select
    Selection.Copy
    Sheets("CSS_quote_sheet").Select
    ActiveSheet.Unprotect
    ActiveSheet.Paste


This inserts the picture into the sheet but I want it placed, not far below label 1. How do I do this?
 

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,147
Office Version
  1. 365
  2. 2016
Platform
  1. Windows

ADVERTISEMENT

Can someone help me with this please?
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,168
Office Version
  1. 2016
Platform
  1. Windows
Get rid of your Save_Object_As_Picture routine, add a new Standard Module to your project, and add the following code to it:

VBA Code:
Option Explicit

Private Type uPicDesc
    Size As Long
    Type As Long
    #If Win64 Then
        hPic As LongPtr
        hPal As LongPtr
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

#If VBA7 Then
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
#Else
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
#End If


Public Function PicFromObject(ByVal Obj As Object, Optional PicType As Long = xlPicture) As StdPicture

   #If Win64 Then
        Dim hPtr As LongLong
    #Else
        Dim hPtr As Long
    #End If
    
    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const CF_BITMAP = 2
    Const PICTYPE_ENHMETAFILE = 4
    Const CF_ENHMETAFILE = 14
    Const LR_COPYRETURNORG = &H4
    Const S_OK = 0&

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim IPic As StdPicture, lPicType As Long
    
    On Error GoTo errHandler
    
    Obj.CopyPicture Appearance:=xlScreen, Format:=PicType
    
    lPicType = IIf(PicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
    
    If OpenClipboard(0) Then
        If IsClipboardFormatAvailable(CF_BITMAP) Then
            hPtr = GetClipboardData(lPicType)
            hPtr = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
        ElseIf IsClipboardFormatAvailable(CF_ENHMETAFILE) Then
            hPtr = GetClipboardData(lPicType)
            hPtr = CopyEnhMetaFile(hPtr, vbNullString)
        End If
        Call EmptyClipboard
        Call CloseClipboard
    End If
    
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    
    With uPicInfo
        .Size = Len(uPicInfo)
        .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
        .hPic = hPtr
        .hPal = 0
    End With
    
    If OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic) = S_OK Then
        Set PicFromObject = IPic
    Else
        MsgBox "Failed to create the StdPicture object."
    End If
    
errHandler:
    Call EmptyClipboard
    Call CloseClipboard

End Function



And then, replace your Wes_header_footer routine, with this one:
VBA Code:
Sub Wes_header_footer()

    Dim printWorksheet As Worksheet, logoShape As Shape, tempImageFile As String
    Dim footshape As Shape, ACAWorksheet As Worksheet
    
    Dim oPic As StdPicture
    
    'The worksheet on which the print page setup will apply
    Set printWorksheet = ThisWorkbook.Worksheets("CSS_quote_sheet")
    'Set ACAWorksheet = ThisWorkbook.Worksheets("ACA_Quoting")
    'The sheet location and name of shape to be used in page setup
    
    Set logoShape = ThisWorkbook.Worksheets("sheet2").Shapes("ImgWestHeader")
    Set footshape = ThisWorkbook.Worksheets("sheet2").Shapes("ImgWestFooter")
    
    'Save the shape as a temporary image
    tempImageFile = Environ("temp") & "\image.wmf"
    
    Set oPic = PicFromObject(logoShape)
    If Not oPic Is Nothing Then
        stdole.SavePicture oPic, tempImageFile
    End If
    
    With printWorksheet.PageSetup
        .CenterHeaderPicture.Filename = tempImageFile
        .CenterHeader = "&G"
    End With
    
    Kill tempImageFile
    
    tempImageFile = Environ("temp") & "\image.wmf"
    
    Set oPic = PicFromObject(footshape)
    If Not oPic Is Nothing Then
        stdole.SavePicture oPic, tempImageFile
    End If
    
    With printWorksheet.PageSetup
        .CenterFooterPicture.Filename = tempImageFile
        .CenterFooter = "&G"
    End With
    
    Kill tempImageFile
        
    Worksheets("CSS_quote_sheet").Activate
    Range("B7").Value = "Ang Wes"
        
End Sub
 

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,147
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Thank you for that, I will test it when I am next at work on Wednesday. ;)
 

Watch MrExcel Video

Forum statistics

Threads
1,127,147
Messages
5,623,008
Members
415,946
Latest member
bellerom

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
Top