Change Logo in Header in many Word-Documents

ika · #1 10-13-2016, 06:52 AM

Hi

I have to change an existing logo - see attachment word-file. The new logo should be placed: horizontaly absolutly-position 13.75 cm measurd right of column, verticaly absolutly-position -0.7 cm under paragraph. The hight is 1.75 cm, the bright is 2.11 cm.

The existing text in the header should be the same.

At least, there are hundreds of word-files in a folder ...

Thx for any advise oder vba-code.

Greeting ika

gmayor · #2 10-13-2016, 09:20 PM

The following macro will do the job, subject to some provisos. The main one is that your example is an accurate reflection of the documents in question. It looks for headers that have one image that is not inserted in-line - and when it finds one it deletes that image and places another in the header at the location specified. There can be many headers in a document! If you want it to address only one header you will have to change the code to reflect that.

The macro is intended to be run from

http://www.gmayor.com/document_batch_processes.htm, which will perform the folder/file handling tasks, as a Custom Process

Code:

Option Explicit

Function ChangeLogo(oDoc As Document) As Boolean
Dim oSection As Section
Dim oHeader As HeaderFooter
Dim oShape As Shape
'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
        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
lbl_Exit:
    Set oSection = Nothing
    Set oHeader = Nothing
    Set oShape = Nothing
    Exit Function
err_handler:
    ChangeLogo = False
    Resume lbl_Exit
End Function

ika · #3 10-14-2016, 07:02 AM

THX a lot gmayor ... I'm gonna test your code asap. Looks great!
Greetings ika

ika · #4 10-14-2016, 07:28 AM

HI Gmyaor

With help from others and google, I created the following code for updating the footers and the properties in wordfiles, located in a folder. How can I now implement your function?

Quote:

Sub SetDocPropsPlus()
'
' SetDocPropsPlus Makro

Dim dd1 As Document
Dim dokupfad As String, endung As String, dateiname As String

dokupfad = "C:\Users\CGL-TEAM1\Desktop\Test Ordner\" '**der Pfad, in dem die zu bearbeitenden Dokumente liegen anpassen!
endung = "*.docx" '**Anpassen, falls nötig!
dateiname = Dir(dokupfad & endung)

'**********Beginn der Schleife durch alle Dateien im Ordner ***************

Do While dateiname <> ""
Set dd1 = Documents.Open(FileName:=dokupfad & dateiname) 'öffnet das Dokument

'********************* Zu wiederholende "Arbeit"****************************************** *************

If Documents.Count > 0 Then
Dim dp As Object
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,"
End If

'Fusszeile ganzer Inhalt erneuern

ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.WholeStory
Selection.Fields.Update
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

'Dokument speichern
dd1.Save

'Dateien schliessen
dd1.Close
Set dd1 = Nothing

'********************Fortsetzung der Schleife durch alle Dokumente********************

dateiname = Dir ' nächste Datei

Loop

End Sub

gmayor · #5 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

ika · #6 10-16-2016, 09:13 AM

Hi Gmayor

Once again, perfect work - thx very much.

As I wrote in my last two posts, I have a folder with many wordfiles ... I create the following code:

Quote:

Sub SetDocPropsPlusFooter()
'
' SetDocPropsPlusFooter Makro
'
Dim dd1 As Document
Dim dokupfad As String, endung As String, dateiname As String

dokupfad = "C:\Users\CGL-TEAM1\Desktop\Test Ordner\" '*path, where all the word files are
endung = "*.docx" '*doc-file
dateiname = Dir(dokupfad & endung)

'loop starts here

Do While dateiname <> ""
Set dd1 = Documents.Open(FileName:=dokupfad & dateiname) 'opens the document

ChangeLogo (????????????)

'save document
dd1.Save

'close document
dd1.Close
Set dd1 = Nothing

'next word file
dateiname = Dir 'next file

Loop

End Sub

How and where can I now start your function ChangeLogo? It needs a document ... but I'm not able to do it ... have you any advise for me?

Thx for your answer.

gmayor · #7 10-16-2016, 08:39 PM

The changelogo function was intended to be used with my add-in, which handles the folder(s), documents, errors and process log, as I said in my initial reply. Download the add-in, run the process and enter ChangeLogo as a custom process.

http://www.gmayor.com/document_batch_processes.htm

ika · #8 10-17-2016, 12:06 AM

I've seen this already, but I'm not allowed do add Add-ins from anyone. In our firm, we have some security laws ... I should have told you this fact earlier - sorry.

So you have any other idea? Thx for your engagement. So how can I add your function to my code presented in the earlier post?

gmayor · #9 10-17-2016, 01:39 AM

It never ceases to amaze me the companies refuse to allow users to download tools to help them do their jobs, but allow them the ability to perform any amount of mayhem by allowing them to use macros. It's just not logical.

Just call the function from your code after opening the document

Code:

ChangeLogo dd1

ika · #10 10-17-2016, 02:45 AM

You're so right. May be you can receive an official certificate ... how ever, now the code works as it should. THX very much.

gmayor · #11 10-17-2016, 05:08 AM

I already have one. I have been a Microsoft Most Valuable Professional (MVP) since 2002!

ika · #12 10-19-2016, 09:22 AM

Yes you are ... one more question. In the part of your code with oshape you define the position of the new logo. How can I define its height and width, for example 1.75 cm height and 2.11 width?

THX for your help.

gmayor · #13 10-19-2016, 08:38 PM

Add the lines

Code:

With oShape 'existing line
                        .Width = CentimetersToPoints(2.11)
                        .Height = CentimetersToPoints(1.75)

ika · #14 10-20-2016, 03:09 AM

THX very much. It works. Two more questions:

1. When I change the height and the width of the logo, changes the image resolution of the logo too? Or is there a special command in VBA so does the image resolution of the logo doesn't change but its height and wigth?
2. We use jpg and gif files ... is there may be a better image format we should use in our process of changing the logo with vba? Better means in this case that we don't loose quality of the image resolution.

THX for your answers.

gmayor · #15 10-20-2016, 03:35 AM

The reason I didn't include the comand to adjust the height and width originally was that the image was already the size indicated so it didn't require to be scaled. Bitmapped images are best inserted at the size they were created as scaling them is not without issues.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro to Insert Logo in header on 1st page only and bookmark it.	youseeme	Word VBA	9	09-16-2016 05:25 AM
How to change logo /dates in numerous word documents without changing each one individually?	newi1	Word VBA	3	04-22-2016 07:02 PM
Can't change logo in Word 2007	jrasicmark	Word	5	04-12-2016 10:35 AM
How to print header logo only in 1st page	Shafraz Khahir	Word	1	11-29-2010 11:52 AM
Is there a way to change the header in a large amount of documents at one time?	ntsstaffing	Word	1	07-11-2009 12:12 PM