Microsoft Office Forums - View Single Post - VBA Script - Add Header

chrisx0x · 11-18-2019, 02:53 PM

Graham - Just made a small donation through your website. Thanks v much.

Andrew - Let me know how I can donate.

Quote:

Originally Posted by gmayor

The following should work. Open a document in Word and run the macro Installing Macros

Don't forget to change the path in the macro to the location where the logo is saved.

The process assumes that the logo is in the centre of the first page header.

Code:

Sub LogoAndPDF()

'Graham Mayor - https://www.gmayor.com - Last updated - 18 Nov 2019
Dim oHeader As Range
Dim strDocName As String
Dim intPos As Integer
Const strLogo As String = "C:\Path\Logo.jpg"    'substitute path of logo
Start:
    strDocName = ActiveDocument.FullName
    intPos = InStrRev(strDocName, ".")
    If intPos = 0 Then
        ActiveDocument.Save
        GoTo Start
    End If
    strDocName = Left(strDocName, intPos - 1)
    ActiveDocument.Sections(1).PageSetup.DifferentFirstPageHeaderFooter = True
    Set oHeader = ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage).Range
    oHeader.End = oHeader.End - 1
    oHeader.InlineShapes.AddPicture FileName:=strLogo
    oHeader.ParagraphFormat.Alignment = wdAlignParagraphCenter

    ActiveDocument.ExportAsFixedFormat OutputFilename:=strDocName, _
                                       ExportFormat:=wdExportFormatPDF, _
                                       OpenAfterExport:=False, _
                                       OptimizeFor:=wdExportOptimizeForPrint, _
                                       Range:=wdExportAllDocument, from:=1, to:=1, _
                                       Item:=wdExportDocumentContent, _
                                       IncludeDocProps:=True, _
                                       KeepIRM:=True, _
                                       CreateBookmarks:=wdExportCreateHeadingBookmarks, _
                                       DocStructureTags:=True, _
                                       BitmapMissingFonts:=True, _
                                       UseISO19005_1:=False
    ActiveDocument.Close SaveChanges:=False
lbl_Exit:
    Set oHeader = Nothing
    Exit Sub
End Sub