none
Why wont this Macro work with my custom watermarks, but finds the built-in building blocks from office 2010? RRS feed

  • Question

  • Option Explicit
    Sub BatchProcess()
    Dim strFileName As String
    Dim strPath As String
    Dim oDoc As Document
    Dim oLog As Document
    Dim oRng As Range
    Dim oHeader As HeaderFooter
    Dim oSection As Section
    Dim fDialog As FileDialog
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

    With fDialog
        .Title = "Select folder and click OK"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then
            MsgBox "Cancelled By User", , _
                   "List Folder Contents"
            Exit Sub
        End If
        strPath = fDialog.SelectedItems.Item(1)
        If Right(strPath, 1) <> "\" _
           Then strPath = strPath + "\"
    End With

    If Documents.Count > 0 Then
        Documents.Close savechanges:=wdPromptToSaveChanges
    End If
    Set oLog = Documents.Add
    If Left(strPath, 1) = Chr(34) Then
        strPath = Mid(strPath, 2, Len(strPath) - 2)
    End If
    strFileName = Dir$(strPath & "*.doc?")

    While Len(strFileName) <> 0
        WordBasic.DisableAutoMacros 1
        Set oDoc = Documents.Open(strPath & strFileName)
        '
        'Do what you want with oDoc here

        For Each oSection In oDoc.Sections
            For Each oHeader In oSection.Headers
                If oHeader.Exists Then
                    Set oRng = oHeader.Range
                    oRng.Collapse wdCollapseStart
                    InsertMyBuildingBlock "ASAP 1", oRng
                End If
            Next oHeader
        Next oSection
        'record the name of the document processed
        oLog.Range.InsertAfter oDoc.FullName & vbCr
        '
        oDoc.Close savechanges:=wdSaveChanges
        WordBasic.DisableAutoMacros 0
        strFileName = Dir$()
    Wend
    End Sub

    Function InsertMyBuildingBlock(BuildingBlockName As String, HeaderRange As Range)
    Dim oTemplate As Template
    Dim oAddin As AddIn
    Dim bFound As Boolean
    Dim i As Long

    bFound = False
    Templates.LoadBuildingBlocks
    For Each oTemplate In Templates
        If InStr(1, oTemplate.Name, "Building Blocks") > 0 Then Exit For
    Next
    For i = 1 To Templates(oTemplate.FullName).BuildingBlockEntries.Count
        If Templates(oTemplate.FullName).BuildingBlockEntries(i).Name = BuildingBlockName Then
            Templates(oTemplate.FullName).BuildingBlockEntries(BuildingBlockName).Insert _
                    Where:=HeaderRange, RichText:=True
            'set the found flag to true
            bFound = True
            'Clean up and stop looking
            Set oTemplate = Nothing
            Exit Function
        End If
    Next i

    If bFound = False Then        'so tell the user.
        MsgBox "Entry not found", vbInformation, "Building Block " _
                                                 & Chr(145) & BuildingBlockName & Chr(146)
    End If
    End Function

    This works, using the ASAP 1 watermark that is in bold. ASAP 1 is a built-in building block, if i just rename this to ASAP, but save it in the same place with buildingblocks.dotx it wont work. What do i need to do to be able to use this with my custom building blocks?

    Monday, February 23, 2015 2:16 PM

Answers

  • Hi alexk2539,

    Based on my testing, I found that the root cause of your problem is at this line:

    For Each oTemplate In Templates
         If InStr(1, oTemplate.Name, "Building Blocks") > 0 Then Exit For
     Next

    By default, word application has a built-in template file which is used to store the built-in building blocks, it's name is "Built-in Building Blocks.dotx". So when the code goes to the above snippet, it firstly find this built-in .dotx file, then set the variable oTemplate to the built-in .dotx template. But as you know, your custom building blocks are stored in a separate template file. So that's why it can't find your custom building blocks.

    To resolve this problem, the simpliest way is to correctly find the template file that store your own custom building blocks. For example, in my case, I stored them into a template file named "Building Blocks.dotx". The modified code is like this:

    For Each oTemplate In Templates
         'If InStr(1, oTemplate.Name, "Building Blocks") > 0 Then Exit For
         If oTemplate.Name = "Building Blocks.dotx" Then Exit For
     Next

    It finally works fine.

    By the way, if you search "word vba insert watermark" in the search engine, you'll find other ways to insert or remove custom watermark, for example, I found this code snippet by Anuradha Goli, which is good I think:

    Option Explicit
    Sub InsertWaterMark()
        Dim strWMName As String
        
        On Error GoTo ErrHandler
         'selects all the sheets
        ActiveDocument.Sections(1).Range.Select
        strWMName = ActiveDocument.Sections(1).Index
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
         'Change the text for your watermark here
        Selection.HeaderFooter.Shapes.AddTextEffect(msoTextEffect1, _
        "DRAFT", "Arial", 1, False, False, 0, 0).Select
        With Selection.ShapeRange
             
            .Name = strWMName
            .TextEffect.NormalizedHeight = False
            .Line.Visible = False
             
            With .Fill
                 
                .Visible = True
                .Solid
                .ForeColor.RGB = Gray
                .Transparency = 0.5
            End With
             
            .Rotation = 315
            .LockAspectRatio = True
            .Height = InchesToPoints(2.42)
            .Width = InchesToPoints(6.04)
             
            With .WrapFormat
                .AllowOverlap = True
                .Side = wdWrapNone
                .Type = 3
                 
            End With
             
            .RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
            .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
            .Left = wdShapeCenter
            .Top = wdShapeCenter
        End With
         
        ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
         
        Exit Sub
         
    ErrHandler:
        MsgBox "An error occured trying to insert the watermark." & Chr(13) & _
        "Error Number: " & Err.Number & Chr(13) & _
        "Decription: " & Err.Description, vbOKOnly + vbCritical, "Error"
         
         
    End Sub
     
     
    Sub RemoveWaterMark()
        Dim strWMName As String
         
        On Error GoTo ErrHandler
         
        ActiveDocument.Sections(1).Range.Select
        strWMName = ActiveDocument.Sections(1).Index
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
        Selection.HeaderFooter.Shapes(strWMName).Select
        Selection.Delete
        ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
         
        Exit Sub
         
         
    ErrHandler:
        MsgBox "An error occured trying to remove the watermark." & Chr(13) & _
        "Error Number: " & Err.Number & Chr(13) & _
        "Decription: " & Err.Description, vbOKOnly + vbCritical, "Error"
         
    End Sub
     
    
    


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    • Marked as answer by alexk2539 Tuesday, February 24, 2015 2:45 PM
    Tuesday, February 24, 2015 7:21 AM
    Moderator