Microsoft Office Forums - View Single Post - [Solved] Change Logo in Header in many Word-Documents

gmayor · 10-14-2016, 09:14 PM

It would make more sense to incorporate the footer changes into the function I posted, to give you the advantage of the error handling and reporting available in the Batch process. It seems that you have some document properties to change and associated fields in the footer, to which no reference was made in your earlier question. That being the case the following should do the job:

Code:

Function ChangeLogo(oDoc As Document) As Boolean
Dim oSection As Section
Dim oHeader As HeaderFooter
Dim oShape As Shape
Dim oStory As Range
Dim dp As DocumentProperties
    'change the path as appropriate
Const strImage As String = "C:\Path\Documents\BEM Logo definitiv Höhe 1.75cm Farben kräftiger.jpg"
    On Error GoTo err_handler
    Set dp = ActiveDocument.BuiltInDocumentProperties
    dp("Title") = "© CGLN-Team und IKA GmbH 2017,2018,2019,"
    dp("Subject") = "© CGLN-Team und IKA GmbH 2017,2018,2019,"
    dp("Keywords") = "© CGLN-Team und IKA GmbH 2017,2018,2019,"
    dp("Category") = "© CGLN-Team und IKA GmbH 2017,2018,2019,"
    dp("Comments") = "© CGLN-Team und IKA GmbH 2017,2018,2019,"
    dp("Author") = "© CGLN-Team 2017,2018,2019,"
    dp("Company") = "© CGLN-Team und IKA GmbH 2017,2018,2019,"
    dp("Manager") = "© CGLN-Team und IKA GmbH 2017,2018,2019,"
    For Each oSection In oDoc.Sections
        For Each oHeader In oSection.Headers
            If oHeader.Exists Then
                If oHeader.Range.ShapeRange.Count = 1 Then
                    oHeader.Range.ShapeRange(1).Delete
                    Set oShape = oHeader.Shapes.AddPicture(FileName:=strImage)
                    With oShape
                        .RelativeHorizontalPosition = _
                        wdRelativeHorizontalPositionColumn
                        .RelativeVerticalPosition = _
                        wdRelativeVerticalPositionParagraph
                        .Left = CentimetersToPoints(13.75)
                        .Top = CentimetersToPoints(-0.7)
                    End With
                    ChangeLogo = True
                End If
            End If
        Next oHeader
    Next oSection
    For Each oStory In ActiveDocument.StoryRanges
        oStory.Fields.Update
        If oStory.StoryType <> wdMainTextStory Then
            While Not (oStory.NextStoryRange Is Nothing)
                Set oStory = oStory.NextStoryRange
                oStory.Fields.Update
            Wend
        End If
    Next oStory
lbl_Exit:
    Set oSection = Nothing
    Set oHeader = Nothing
    Set oShape = Nothing
    Set oStory = Nothing
    Exit Function
err_handler:
    ChangeLogo = False
    Resume lbl_Exit
End Function