Sub to load a custom header and footer

[dpaton05]

I have a sub that is meant to load a custom header and footer

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

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:

Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width + 1, saveObject.Height + 1)

Could someone help me work out the problem please?

 

[Jaafar Tribak]

Do a search for OleCreatePictureIndirect to see how you can create a StdPicture object from the shapes.

 

[dpaton05]

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]

I used the macro recorder to record a macro that gave this 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]

Can someone help me with this please?

 

[Jaafar Tribak]

Get rid of your Save_Object_As_Picture routine, add a new Standard Module to your project, and add the following code to it:

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:

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]

Thank you for that, I will test it when I am next at work on Wednesday.