vbams-wordheaderfooter

VBA insert table in header


I want to insert 2 column and one row in header using vba. I tried the following code but it works one time and gives the error 6028 (the range cannot be deleted) other time. Can any one suggest me any solution.

Sub UpdateHeader()

    Dim oDoc As Word.Document, oSec As Word.Section, rng As Word.Range
    Set oDoc = ActiveDocument

    For Each oSec In oDoc.Sections
        Set rng = oSec.Headers(Word.WdHeaderFooterIndex.wdHeaderFooterFirstPage).Range
        AddHeaderToRange rng

        Set rng = oSec.Headers(Word.WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
        AddHeaderToRange rng
    Next oSec
End Sub

Private Sub AddHeaderToRange(rng As Word.Range)
    With rng
        .Tables.Add Range:=rng, NumRows:=1, NumColumns:=2
        With .Tables(1)
            .Borders.InsideLineStyle = wdLineStyleNone
            .Borders.OutsideLineStyle = wdLineStyleNone
            .Rows.SetLeftIndent LeftIndent:=-37, RulerStyle:=wdAdjustNone
            .Columns(2).SetWidth ColumnWidth:=300, RulerStyle:=wdAdjustNone
            .Cell(1, 1).Range.InlineShapes.AddPicture FileName:="Your Pic Solution", LinkToFile:=False, SaveWithDocument:=True
            .Cell(1, 2).Range.Font.Name = "Arial"
            .Cell(1, 2).Range.Font.Size = 9
            .Cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
            .Cell(1, 2).Range.Text = "Test header" & vbNewLine & "Second Line"
        End With
    End With
End Sub

Solution

  • Try:

    Sub UpdateHeaders()
    Application.ScreenUpdating = False
    Dim Tbl As Table, Sctn As Section
    With ActiveDocument
      Set Tbl = .Tables.Add(Range:=.Range(0, 0), NumRows:=1, NumColumns:=2)
      With Tbl
        .Borders.InsideLineStyle = wdLineStyleNone
        .Borders.OutsideLineStyle = wdLineStyleNone
        .Rows.SetLeftIndent LeftIndent:=-37, RulerStyle:=wdAdjustNone
        .Columns(2).SetWidth ColumnWidth:=300, RulerStyle:=wdAdjustNone
        .Cell(1, 1).Range.InlineShapes.AddPicture FileName:="Your Pic Solution", LinkToFile:=False, SaveWithDocument:=True
        .Cell(1, 2).Range.Font.Name = "Arial"
        .Cell(1, 2).Range.Font.Size = 9
        .Cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
        .Cell(1, 2).Range.Text = "Test header" & vbCr & "Second Line"
      End With
      For Each Sctn In .Sections
        With Sctn
          With .Headers(wdHeaderFooterPrimary)
            If .LinkToPrevious = False Then .Range.FormattedText = Tbl.Range.FormattedText
          End With
          With .Headers(wdHeaderFooterFirstPage)
            If .LinkToPrevious = False Then .Range.FormattedText = Tbl.Range.FormattedText
          End With
        End With
      Next
      Tbl.Delete
    End With
    Application.ScreenUpdating = True
    End Sub