利用VBA给文档批量添加水印

直接复制代码到编译器中运行，选择文件文件夹和图片，将进行批处理，进行水印的批量添加，添加完成后可以看到存储的文件副本为“文件名+水印后”

注：
为保证水印可以铺满文档，所以图片水印默认扩大为1.5倍

宏代码：

Rem 这里是主程序
Sub 批量获取文件路径()
Dim fd As FileDialog
Dim fso As Object
Dim arr() '存储每次遍历到的文件夹的子文件夹
Dim brr() '临时存储每次遍历到的文件夹的子文件夹
Dim crr() '存储所有文件夹
Dim drr() '存储所有Word文件路径
Dim myFolder As Object
Dim subFolder As Variant
Dim i As Long
Dim j As Long
Dim m As Long
Dim myFile As Object
Dim 后缀 As String
Dim t0 As Single
Dim fd1 As FileDialog
Dim 水印图片路径 As String

t0 = Timer
i = 0: j = 0: m = 0
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Set fso = CreateObject("Scripting.FileSystemObject")

With fd
    .Title = "选择主文件夹"
    If .Show Then
        i = i + 1
        ReDim Preserve crr(1 To i)
        crr(i) = .SelectedItems(1)
        arr = crr
        
        Set fd1 = Application.FileDialog(msoFileDialogFilePicker)
        With fd1
            .AllowMultiSelect = False
            .Title = "选择图片水印文件"
            .Filters.Clear
            .Filters.add "图片文件", "*.png;*.jpeg;*.jpg", 1
            .Filters.add "所有文件", "*.*", 2
            If .Show Then
                水印图片路径 = .SelectedItems(1)
            End If
        End With
        Set fd1 = Nothing
        
        On Error Resume Next
        Do While Err.Number = 0
            For j = LBound(arr) To UBound(arr)
                Set myFolder = fso.GetFolder(arr(j))
                If myFolder.subFolders.Count > 0 Then
                    For Each subFolder In myFolder.subFolders
                        i = i + 1
                        ReDim Preserve crr(1 To i)
                        crr(i) = subFolder.Path
                        
                        m = m + 1
                        ReDim Preserve brr(1 To m)
                        brr(m) = subFolder.Path
                    Next
                End If
            Next
            m = 0
            arr = brr
            Erase brr
        Loop
        On Error GoTo 0
        
        i = 0
        For j = LBound(crr) To UBound(crr)
        '                Debug.Print j, crr(j)
            Set myFolder = fso.GetFolder(crr(j))
            For Each myFile In myFolder.Files
                后缀 = fso.GetExtensionName(myFile.Path)
                If 后缀 Like "doc*" And Not 后缀 Like "*~$*" Then
                    i = i + 1
                    ReDim Preserve drr(1 To i)
                    drr(i) = myFile.Path
                End If
            Next
        Next
        
        For j = LBound(drr) To UBound(drr)
            Rem 此处以下为调用的处理过程
            
            Application.ScreenUpdating = False
            Call 遍历节(drr(j), 水印图片路径)
            Application.ScreenUpdating = True
            
            Rem 此处以上为调用的处理过程
            Debug.Print Format(j, String(Len(CStr(UBound(drr))), "0")), drr(j), "添加水印完成"
        Next
    End If
End With

Set fd = Nothing
Set fso = Nothing
Set myFolder = Nothing

Debug.Print "完成   共对" & UBound(drr) & "个文件添加了水印   用时" & Timer - t0 & "秒"
End Sub
Sub 遍历节(文件名, 水印图片路径 As String)
Dim aDoc As Document
Dim sec As Section
Dim hf As HeaderFooter
Dim fso As Object
Dim fName As String
Dim fNewName As String

Set aDoc = Documents.Open(文件名)
Set fso = CreateObject("Scripting.FileSystemObject")

fNewName = aDoc.Path & "\" & fso.GetBaseName(文件名) & "-水印后." & fso.GetExtensionName(文件名)

For Each sec In aDoc.Sections
    For Each hf In sec.Headers
        Call 添加图片水印(hf, 水印图片路径)
    Next
Next
aDoc.SaveAs2 FileName:=fNewName, FileFormat:=aDoc.SaveFormat
aDoc.Close wdSaveChanges

Set aDoc = Nothing
Set fso = Nothing 
End Sub
Sub 添加图片水印(hf As HeaderFooter, 水印图片路径 As String)
Dim 线型 As Long

线型 = hf.Range.ParagraphFormat.Borders.InsideLineStyle
hf.Shapes.AddPicture(FileName:=水印图片路径, LinkToFile:=False, SaveWithDocument:=True).Select
With Selection.ShapeRange
.PictureFormat.Brightness = 0.5
.PictureFormat.Contrast = 0.5
.LockAspectRatio = True
.Height = CentimetersToPoints(24.25)
.Width = CentimetersToPoints(15.48)
.WrapFormat.AllowOverlap = True
.WrapFormat.Side = wdWrapNone
.WrapFormat.Type = 3
.RelativeHorizontalPosition = _
    wdRelativeVerticalPositionMargin
.RelativeVerticalPosition = _
    wdRelativeVerticalPositionMargin
.Left = wdShapeCenter
.Top = wdShapeCenter
End With
hf.Range.ParagraphFormat.Borders.InsideLineStyle = 线型
End Sub