How to add watermark to multiple word files of .doc & .docx extensions?

I can't see any reason in the code that *.doc files won't be processed the same as *.docx files. The statement

strFileName = Dir$(strPath & "*.doc?")

does find files with both extensions, as the question mark is interpreted as "zero or one character".

In later versions of Word, there's a page in the Options > Trust Center Settings dialog with file block settings, which could be set to prevent opening of *.doc files. However, Word 2010 is the first version where that appears.

Try this: Open the macro editor, place the cursor in the BatchProcess macro, and start pressing the F8 key. Each press runs one statement, and the current statement is highlighted in yellow. Watch the progress as the macro works, and hover the mouse pointer over variable names or use the Watch Window to see the values. Try to determine at what point a *.doc file is being skipped, and why.

The simplest solution at this stage would be to run the macro a second time, changing:

Dir(strFldr & "\*.doc", vbNormal)

to:

Dir(strFldr & "\*.rtf", vbNormal)

Thankyou so much :)

Yes your code worked.

& Yes, I had to update with your given function.

There are some (400+ files) Rich Text Format (.rtf) files which also need to have a watermark. As MS word by default opens Rich Text Format (.rtf) files in ms word so, I want to ask you there is a way for macro to do this with the code you provided:

Option Explicit

Dim FSO As Object, oFolder As Object, StrFolds As String

Sub Main()

Application.ScreenUpdating = False

Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long

TopLevelFolder = GetFolder

If TopLevelFolder = "" Then Exit Sub

StrFolds = vbCr & TopLevelFolder

If FSO Is Nothing Then

Set FSO = CreateObject("Scripting.FileSystemObject")

End If

'Get the sub-folder structure

Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders

For Each aFolder In TheFolders

RecurseWriteFolderName (aFolder)

Next

'Process the documents in each folder

For i = 1 To UBound(Split(StrFolds, vbCr))

Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))

Next

Application.ScreenUpdating = True

End Sub

Sub RecurseWriteFolderName(aFolder)

Dim SubFolders As Variant, SubFolder As Variant

Set SubFolders = FSO.GetFolder(aFolder).SubFolders

StrFolds = StrFolds & vbCr & CStr(aFolder)

On Error Resume Next

For Each SubFolder In SubFolders

RecurseWriteFolderName (SubFolder)

Next

End Sub

Function GetFolder() As String

Dim oFolder As Object

GetFolder = ""

Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)

If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path

Set oFolder = Nothing

End Function

Sub UpdateDocuments(oFolder As String)

Dim strFldr As String, strFile As String, wdDoc As Document

Dim Rng As Range, Sctn As Section, HdFt As HeaderFooter, Shp As Shape

strFldr = oFolder

If strFldr = "" Then Exit Sub

strFile = Dir(strFldr & "\*.doc", vbNormal)

While strFile <> ""

Set wdDoc = Documents.Open(FileName:=strFldr & "" & strFile, AddToRecentFiles:=False, ReadOnly:=False, Visible:=False)

With wdDoc

'Loop through all headers

For Each Sctn In .Sections

For Each HdFt In Sctn.Headers

With HdFt

'Watermark headers in use

If .Exists = True Then

If Sctn.Index = 1 Then

Set Rng = .Range

Rng.Collapse wdCollapseStart

InsertMyBuildingBlock "CONFIDENTIAL 1", Rng

ElseIf .LinkToPrevious = False Then

Set Rng = .Range

Rng.Collapse wdCollapseStart

InsertMyBuildingBlock "CONFIDENTIAL 1", Rng

End If

End If

End With

Next

Next

'Save and close the document

.Close SaveChanges:=wdSaveChanges

End With

strFile = Dir()

Wend

Set wdDoc = Nothing

End Sub

Function InsertMyBuildingBlock(BuildingBlockName As String, HeaderRange As Range)

Dim oTemplate As Template, oAddin As AddIn, bFound As Boolean, i As Long

bFound = False

Templates.LoadBuildingBlocks

For Each oTemplate In Templates

  If InStr(1, oTemplate.Name, "Building Blocks") > 0 Then

    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 For

      End If

    Next i

    Exit For

  End If

Next

If bFound = False Then  'so tell the user.

  MsgBox "Entry not found", vbInformation, "Building Block " & Chr(145) & BuildingBlockName & Chr(146)

End If

End Function