Microsoft Office Forums - View Single Post - [Solved] Amend text shape in header with VBA

Welshgasman · 09-19-2016, 01:02 AM

Good morning,

Here is my existing code

Code:

Sub EditHeaderTextBox()
Dim sh As Shape
    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
    
    ' Switch off the updates of screen
    Application.ScreenUpdating = False
    
    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))
        ' *** Always use the AlignRight code loine as editing bugegrs up the alignment ***
        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, "aaa", "bbb")
                sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "ccc", "ddd")
                sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "eee", "fff")
                'sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "ggg", "hhh")
                'sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "iii", "jjj")
                sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "kkk", "lll")
                'sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "mmm", "nnn")
                'sh.TextFrame.TextRange.Paragraphs.Alignment = wdAlignParagraphRight
                sh.TextFrame.MarginLeft = sh.TextFrame.MarginLeft - 5
                sh.TextFrame.MarginTop = sh.TextFrame.MarginTop - 5
                sh.TextFrame.TextRange.Font.Size = 10
                sh.TextFrame.AutoSize = True
            End If
        Next sh
        Doc.Save
        Doc.Close
    Next i
    
Exit_Sub:
        ' Switch SCreen updates back on
        Application.ScreenUpdating = True
        Set docToOpen = Nothing
        Set Doc = Nothing
        Exit Sub
Err_Exit:
    MsgBox Err.Description & Err.Number
    
End Sub

I have since discovered an example on how to insert text

Code:

'What.TextFrame.TextRange.InsertParagraph
What.TextFrame.TextRange.InsertAfter "The quick brown monkey jumped over the lazy elephant's back"

an am thinking slightly differently now, in that I could delete all the existing text in the text box and add afresh?
Would still need to adjust the header depth for any increase in depth of the textbox.

TIA