批量生成word文档并加不同的水印-vba

xuemei0216

希望大神能帮忙写一个宏代码，实现以下功能。有一个公司制度的word 模板，按照excel表中的三个名字，生成三个文档，并加上不同的水印。1、文档名字分别是公司制度-李一；公司制度-李二；公司制度-李三。文档内容相同，只是另存为的文字不同而已

2、三个文档水印不同，分别是李一，李二，李三。


后面会把文档生成为pdf，发送给相应的员工。

xuemei0216

自己研究出来了。有需要的可以用。

AdenGao

您好，我下载了您批量生成文档并加不同水印的程序，使用过程中，生成的文档没有水印。想再向您请教一下，不知是否方便？微信gaoyingda1995，多有打扰还请见谅。祝好~

冷空机旁

AdenGao 发表于 2020-5-8 18:55
您好，我下载了您批量生成文档并加不同水印的程序，使用过程中，生成的文档没有水印。想再向您请教一下，不 ...

有结果吗，我下载了不知道怎么用

rrxfw

不错，很好用。如果代码都整合到excel vba，不用在word中操作vba就完美了

forlovewyz

根据xuemei0216分享，优化了代码：
一、实现了代码都整合到excel vba，不用在word中操作vba。
二、实现了水印在页面十二宫格区域有水印。
模块一代码：
Sub a()
    Dim i As Long
    Dim s As String
    Dim MyFile As Object
    Set MyFile = CreateObject("Scripting.FileSystemObject")
    Application.StatusBar = "正在导入数据，请稍候..."
    ' 创建一个字典来存储编号和水印名的映射
    Dim DataDict As Object
Set DataDict = CreateObject("Scripting.Dictionary")

' 将数据区域加载到数组中（假设数据从A2开始）
With ThisWorkbook.Worksheets("Sheet1")
    Dim LastRow As Long
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   
    ' 创建二维数组来存储数据
    Dim DataArray() As Variant
    DataArray = .Range("A2:B" & LastRow).Value ' 获取A列和B列的数据并存入数组

    ' 遍历数组填充字典
   
    For i = LBound(DataArray, 1) To UBound(DataArray, 1)
        If Not IsEmpty(DataArray(i, 1)) And Not IsEmpty(DataArray(i, 2)) Then
            Dim Key As String
            Key = DataArray(i, 1) ' 直接获取编号（数组中的第二列）
            Dim Value As String
            Value = DataArray(i, 2) ' 直接获取水印名（数组中的第一列）

            DataDict.Add Key, Value ' 将编号作为Key，水印名为Value添加到字典中
        End If
    Next i
End With
   
    ' 指定文件夹路径
    Dim folderPath As String
    folderPath = ThisWorkbook.Path & "\生成文件"
      
    ' 删除并重新创建文件夹
    On Error Resume Next
    MyFile.DeleteFolder (folderPath)
    On Error GoTo 0
    MyFile.CreateFolder (folderPath)
      
    ' 获取Word文件路径
    s = Application.GetOpenFilename(FileFilter:="Word文件,*.doc*", MultiSelect:=False)
    If s = "False" Then Exit Sub
    'MsgBox "正在导入指定word水印,请稍后......"
      
    ' 复制文件到新建文件夹中并按指定格式命名
    For i = 2 To LastRow
        Dim DocIndex As String
        DocIndex = CStr(ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value) ' 获取当前行的编号
        
        If DataDict.Exists(DocIndex) Then
            Dim WatermarkName As String
            WatermarkName = DataDict(DocIndex) ' 根据编号获取对应的水印名
            
            FileCopy s, folderPath & "\" & MyFile.GetBaseName(s) & "-" & WatermarkName & "-" & DocIndex & ".docx"
        Else
            MsgBox "编号 " & DocIndex & " 在字典中未找到对应的水印名。"
        End If
    Next i

    Call ExcelAddWatermark
    MsgBox "已一键完成水印导入，请查看、打印！"
End Sub
模块二代码：
Option Explicit

Function CentimetersToPoints(CmValue As Double) As Double
    CentimetersToPoints = CmValue * 28.3464566929134 ' 厘米转换为磅的系数
End Function

Sub ExcelAddWatermark()
    Dim GetStr As String, Adoc As String
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim MyDialog As FileDialog
    Dim WatermarkName As String
    Dim WkName As String
    Dim i As Long
    Dim DocIndex As String
    Dim DataRow As Long
    Dim DataDict As Object
    Set DataDict = CreateObject("Scripting.Dictionary")

   
    Application.ScreenUpdating = False
   
   
   
    GetStr = ThisWorkbook.Path & "\生成文件"
    If Not Dir(GetStr, vbDirectory) <> "" Then MkDir GetStr
   
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then Set wdApp = CreateObject("Word.Application")
    On Error GoTo 0
   
    wdApp.Visible = False ' 根据需求可改为True
   
    ' 将数据区域加载到数组中（假设数据从A2开始）
With ThisWorkbook.Worksheets("Sheet1")
    Dim LastRow As Long
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   
    ' 创建二维数组来存储数据
    Dim DataArray() As Variant
    DataArray = .Range("A2:B" & LastRow).Value ' 获取A列和B列的数据并存入数组

    ' 遍历数组填充字典
   
    For i = LBound(DataArray, 1) To UBound(DataArray, 1)
        If Not IsEmpty(DataArray(i, 2)) Then
            DocIndex = DataArray(i, 1) ' 直接获取编号（数组中的第1列）
            WkName = DataArray(i, 2) ' 直接获取水印名（数组中的第2列）

            DataDict.Add DocIndex, WkName ' 将编号作为Key，水印名为Value添加到字典中
        End If
    Next i
End With
   
    Adoc = Dir(GetStr & "\*.doc*")
  
    Do While Adoc <> ""
        Set wdDoc = wdApp.Documents.Open(GetStr & "\" & Adoc)
      ' 从文件名中提取文档编号（根据文件名格式“模板名-水印名编号.docx”）
        Dim fileNameParts() As String
        fileNameParts = Split(wdDoc.Name, ".")
        ' 分割得到不包含扩展名的部分
        Dim baseNameParts() As String
        baseNameParts = Split(fileNameParts(0), "-")

        ' 假设最后一个部分是编号
        DocIndex = baseNameParts(UBound(baseNameParts))

        WatermarkName = DataDict(DocIndex)
      

       With wdDoc.Sections(1).Headers(wdHeaderFooterPrimary)
            .Range.Text = "NCBM编号：" & WatermarkName & "-" & Format(DocIndex, "000")
            ' 设置字体样式、位置等...
        End With
                       
        ' 调用子程序设置水印，传递正确的水印名
        SetWatermark wdApp, wdDoc, WatermarkName
        
        wdDoc.Save
        Set wdDoc = Nothing
        Adoc = Dir() ' 获取下一个文件
    Loop
   
    wdApp.Quit
    Set wdApp = Nothing
    Set DataDict = Nothing
     
     Application.StatusBar = "" ' 清除状态栏信息
    Application.ScreenUpdating = True
End Sub

Sub SetWatermark(wdApp As Word.Application, wdDoc As Word.Document, WatermarkName As String)
    Dim WatermarkShape As Word.shape
    Dim PositionX(), PositionY() As Variant
    Dim j As Integer, k As Integer
  
    PositionX = Array(CentimetersToPoints(-1.5), CentimetersToPoints(2.5), CentimetersToPoints(6.5), CentimetersToPoints(10.5), CentimetersToPoints(14.5))
    PositionY = Array(CentimetersToPoints(2), CentimetersToPoints(7), CentimetersToPoints(12), CentimetersToPoints(17), CentimetersToPoints(22))

    With wdDoc.Sections(1)
    .Headers(wdHeaderFooterPrimary).Range.Font.Size = 16 ' 设置页眉字体大小
        wdApp.ActiveWindow.View.SeekView = wdSeekCurrentPageHeader ' 切换到页眉视图
        
        ' 清除旧水印
        For Each WatermarkShape In .Headers(wdHeaderFooterPrimary).Shapes
            If WatermarkShape.Name Like "PowerPlusWaterMarkObject*" Then
                WatermarkShape.Delete
            End If
        Next WatermarkShape
        
        ' 在十二宫格每个位置插入水印
        For j = 1 To 5
            For k = 1 To 5
                Set WatermarkShape = .Headers(wdHeaderFooterPrimary).Shapes.AddShape(msoShapeRectangle, 0, 0, CentimetersToPoints(2), CentimetersToPoints(1))
                With WatermarkShape
                    .TextFrame.TextRange.Text = WatermarkName
                    .TextFrame.TextRange.Font.Size = 16
                    .TextFrame.TextRange.Font.Name = "宋体"
                    .TextFrame.WordWrap = msoFalse
                    .Fill.Visible = False
                    .Line.Visible = False
                    .TextFrame.TextRange.ParagraphFormat.Alignment = msoAlignCenter
                    .Rotation = 315
                    .Left = PositionX(j - 1)
                    .Top = PositionY(k - 1)
                    .Width = CentimetersToPoints(2)
                    .Height = CentimetersToPoints(1)
                    .Name = "PowerPlusWaterMarkObject" & j & k
                    .Fill.Solid
                    .TextFrame.TextRange.Font.Color = RGB(255, 0, 0)
                    .Fill.Transparency = 1
                    .LockAspectRatio = msoFalse
                End With
            Next k
        Next j
        End With
End Sub

xustyle

forlovewyz 发表于 2024-2-16 21:23
根据xuemei0216分享，优化了代码：
一、实现了代码都整合到excel vba，不用在word中操作vba。
二、实现了 ...

楼主真是活菩萨，这么好的代码直接公布，好人一生平安。
我也是在找同样的功能，代码小白，用ChatGPT一直搞不定，刚好就搜到了这个。
有几个小白需要注意的地方，
①楼主的vba代码中使用了几个kingsoft的运行库，会提示缺失，直接把前面的√取消即可，不然会提示找不到工程或库；
②需要启用Microsoft Word 16.0 Object Library这个库，否则会提示代码未定义。关键代码在这段Sub SetWatermark(wdApp As Word.Application, wdDoc As Word.Document, WatermarkName As String)

sunshuangzhong

请问：这个在实际工作中有什么用途?谢谢