Edit (replace text) header VBA

[Gasman]

Hi all,

Word 2007.

I found some code on the net and amended it to do as I need.

I tested it at home and it worked fine.

I emailed myself the .docm document with the code in it.

When I run it in work on my new computer, it wipes out the header completely and also creates a second page.?

Can anyone please explain what I am missing?

I thought it might be due to references as this computer is new, but it does not complain about any code at all.

TIA

Sub EditHeader()
    Dim Doc As Document
    Dim i As Integer
    Dim docToOpen As FileDialog
    Dim strText As String
    Dim blnSave As Boolean
    
    blnSave = True
    
    On Error GoTo Err_Exit
    
    Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
    docToOpen.Show
    For i = 1 To docToOpen.SelectedItems.Count
        'Open each document
        Set Doc = Documents.Open(FileName:=docToOpen.SelectedItems(i))
        'With Doc.Sections(1)
            'remove all existing headers and footers
        '    Call RemoveHeadAndFoot
        'End With
        With Doc.Sections(1)
            'insert new headers
            'strText = .Headers(wdHeaderFooterPrimary).Range.Text
            'now replace the text
            'strText = Replace(strText, "aaaa", "bbbbb")
            'strText = Replace(strText, "cccc", "ddddd")
            .Headers(wdHeaderFooterPrimary).Range.Text = Replace(.Headers(wdHeaderFooterPrimary).Range.Text, "aaaa", "bbbb)
            .Headers(wdHeaderFooterPrimary).Range.Text = Replace(.Headers(wdHeaderFooterPrimary).Range.Text, "cccc", "ddddd")
            .Headers(wdHeaderFooterPrimary).Range.Text = Replace(.Headers(wdHeaderFooterPrimary).Range.Text, "eeee", "fffff")
            .Headers(wdHeaderFooterPrimary).Range.Text = Replace(.Headers(wdHeaderFooterPrimary).Range.Text, "gggg", "hhhhh")
            .Headers(wdHeaderFooterPrimary).Range.Text = Replace(.Headers(wdHeaderFooterPrimary).Range.Text, "iiii", "jjjjj")
            .Headers(wdHeaderFooterPrimary).Range.Text = Replace(.Headers(wdHeaderFooterPrimary).Range.Text, "kkkk", "lllll")
            
            '.Range.Paragraphs.Alignment = wdAlignParagraphRight
        End With
        'With ActiveDocument.Sections(1)
            'insert new footers
            'Call editfooter
        'End With
        Doc.Save
        Doc.Close
    Next i
    
Err_Exit:
Set docToOpen = Nothing
Set Doc = Nothing

End Sub

 

[kevlray]

Because I wanted to see the code better. I copied the above code to Word (VBA) and noticed that you are missing a closing " on your first .Header line. The code should not execute. As far as the rest of the code. I see nothing that would create a new document. Furthermore, I tested the code and it seems to preform as expected.

 

[Gasman]

Thank you Kev,

That is a typo on my part as I amended the text as it had personal details in it, and missed off that last " character.

It worked at home also on 2007, which is why it puzzled me. I am taking the files home tonight and will try and amend there.

Thank you for trying it out and confirming it works for you.

 

[Gasman]

Well I am trying the actual documents at home and they fail as well.
As far as I can tell, if there is no graphic in the header, the replace works.

The address I am trying to change is in a text box in the header and when I was testing, trying this out, I did not use a text box, as I did not realise that was how the text was being stored.

Ah well, a lot of copy and paste to do now.

You live and learn.

 

[kevlray]

Some years back, one of my clients wanted to be able to put data into the footer when they opened the document (Probably before this forum existed). It took a lot of digging to find the right code to get it to work. I understand your pain

 

[Gasman]

Hi Kev,

I even found an old thread by Galaxiom with supplied code and could not get that to work.
I believe I have several sections in the header.
A Picture on the left, a text box in the middle and a text box on the right that holds the address I was trying to amend.

Plain text is fine, and that is what I tested on, not realising that there are subtle differences with text box.

I even found an old thread http://www.access-programmers.co.uk/forums/showthread.php?t=227122&highlight=replace+text and could not get that to work, even in the main document, so will revisit that when I have time. Fortunately the headers will not change again for a good while (I hope), but it would be nice to be able to do it.

 

[Gasman]

Well I am getting there

Found some code to edit text box at https://www.experts-exchange.com/questions/27274592/Word-VBA-access-Text-box-in-header.html

Sub EditHeaderTextBox()
Dim sh As Shape

For Each sh In ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
    If sh.Type = msoTextBox Then
        sh.TextFrame.TextRange.Text = "Some text"
    End If
Next sh
End Sub

and amended it to

Sub EditHeaderTextBox()
Dim sh As Shape

For Each sh In ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
    If sh.Type = msoTextBox Then
        sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "XXX Business Centre", "Line 1 replaced")
        sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "Pembrokeshire House", "Line 2 replaced")
        
    End If
Next sh
End Sub

This does the substitution correctly , but corrupts the alighment (right) and mucks up the other text box which is centered, so added a check for the text box name.

I had to find the name of the text box in the Locals window. I could not see any way of naming when creating a text box.

Then tweaked it with the Intellisense to get

Sub EditHeaderTextBox()
Dim sh As Shape

For Each sh In ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
    If sh.Type = msoTextBox And sh.Name = "Text Box 1" Then
        sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "XXX Business Centre", "Line 1 replaced")
        sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "Pembrokeshire House", "Line 2 replaced")
        sh.TextFrame.TextRange.Paragraphs.Alignment = wdAlignParagraphRight
        
    End If
Next sh
End Sub

Wish I had this the other night. :banghead:

Learnt a lot tonight.