vbaexcelms-wordwatermarkbuildingblocks

Issue using Excel VBA to add Watermark to Word Document using BuildingBlockEntry


I am currently trying to use Excel VBA to add a watermark to a Word document. I have been able to do so from Word VBA and have translated the code over to excel to implement other functions, and am getting an error on a specific line. I believe I need to better point to the Word building block when requesting the insert of the watermark, but am unsure.

The error is "The requested member of the collection does not exist" from the line: oWord.Templates(strBBPath).BuildingBlockEntries(strBBName).Insert Where:=oRng, RichText:=True

Here is my code:

    Sub AddWatermark()
     Dim oWord as Word.Application
     Dim oDoc As Word.Document
     Dim oSection As Word.section
     Dim oHeader As Word.HeaderFooter
     Dim oRng As Word.Range
     Dim strName As String
     Dim strPath As String
     Dim strBBPath As String
     Const strBBName As String = "SAMPLE 1" 'The building block name that you want to insert

     strBBPath = "C:\Users\" & (Environ$("Username")) & "\AppData\Roaming\Microsoft\Document Building Blocks\1033\14\Built-In Building Blocks.dotx"

               Dim lngCount As Long

               ' Open the file dialog
               With Application.FileDialog(msoFileDialogOpen)
                   .AllowMultiSelect = True
                   .Show

                   ' Display paths of each file selected
                   For lngCount = 1 To .SelectedItems.Count
                        Set oWord = New Word.Application
                        strPath = .SelectedItems(lngCount)
                        Set oDoc = oWord.Documents.Open(strPath)
                   Next lngCount
               End With

     'oDoc.Save 'save the document
     strName = oDoc.FullName 'Record the document name
     oWord.Visible = True

     'Address each section
     For Each oSection In oDoc.Sections
         'Address each header in the section
         For Each oHeader In oSection.Headers

             Set oRng = oHeader.Range
             oRng.Start = oRng.End 'set the range to the end of the header
             'Insert the built-in building block
             oWord.Templates(strBBPath).BuildingBlockEntries(strBBName).Insert Where:=oRng, RichText:=True

         Next oHeader
     Next oSection

     End Sub

Solution

  • I found an answer for this one from this post - https://answers.microsoft.com/en-us/msoffice/forum/msoffice_word-mso_other/run-time-error-5941-not-always-but-annoyingly/b95ec1db-6928-4d87-b799-52d4f1c01f08

    The Word building blocks need to be loaded to pull from using this method: oWord.Templates.LoadBuildingBlocks

    Thank you to everyone who took a look. :)