Excel表的内容批量生成个人加水印的Word文档

Excel表的内容批量生成个人加水印的Word文档

以下代码可以直接复制到docm文件里使用

Sub 宏1()

Dim MyDialog As FileDialog
    Dim GetStr As String, Adoc As String
    Dim PsDoc As Document
    Application.ScreenUpdating = False
    Set MyDialog = Application.FileDialog(msoFileDialogFolderPicker)
        If MyDialog.Show Then GetStr = MyDialog.SelectedItems(1) Else Exit Sub
        Adoc = Dir(GetStr & "\*.doc*")
        Do While Adoc <> ""    '如果是文件夹,或者没有此文件,则会返回""
            Set PsDoc = Documents.Open(GetStr & "\" & Adoc) '打开指定文档
            On Error Resume Next
                ActiveDocument.Sections(1).Range.Select
                ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader  '插入水印前需更改视图样式为页眉视图
                Selection.HeaderFooter.Shapes("PowerPlusWaterMarkObject1019930437").Select      '选中当前水印
                Selection.Delete         '删除旧水印
            '设置插入水印，(预设文字效果, 文字内容, 字体名, 字体大小, 是否粗体, 是否斜体, 左侧位置, 顶部位置)
                Selection.HeaderFooter.Shapes.AddTextEffect(PowerPlusWaterMarkObject1019930437, _
                Split(Split(ActiveDocument.Name, ".")(0), "-")(1), "宋体", 36, False, False, 0, 0).Select
                Selection.Style = ActiveDocument.Styles("正文")
            With Selection.ShapeRange
                    .Name = "PowerPlusWaterMarkObject1019930437"            '形状类名
                    .TextEffect.NormalizedHeight = False            '文字文字效果
                    .Line.Visible = False           '线条是否可见
                    .Fill.Visible = True                '填充是否可见
                    .Fill.Solid         '填充类型（本例为纯色）
                    .Fill.ForeColor.RGB = RGB(255, 0, 0)                     '设定填充的颜色RGB值
                    .Fill.Transparency = 0.5           '设置透明度50%
                    .Rotation = 315                  '设置旋转角度
                    .LockAspectRatio = True              '锁定纵横比
                    .Height = CentimetersToPoints(10.33)             '高度
                    .Width = CentimetersToPoints(10.33)                 '宽度
                    .WrapFormat.AllowOverlap = True                 '是否允许重叠
                    .WrapFormat.Side = wdWrapNone               '是否设置文字环绕
                    .WrapFormat.Type = 3                '设置折回样式（本例设为不折回）
                    .RelativeHorizontalPosition = wdRelativeVerticalPositionMargin              '设置水平位置与纵向页边距关联
                    .RelativeVerticalPosition = wdRelativeVerticalPositionMargin                 '设置垂直位置与横向页边距关联
                    .Left = wdShapeCenter           '水平居中
                    .Top = wdShapeCenter            '垂直居中
            End With
                       '去除页眉上的横线
              ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
              ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
              Selection.Style = ActiveDocument.Styles("正文")
              
              ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
              PsDoc.Close True
            Adoc = Dir()
        Loop
    Application.ScreenUpdating = True
End Sub

以下代码是excel运行的代码

Option Explicit

Sub a()
Dim i%
Dim s$
Dim MyFile As Object
Set MyFile = CreateObject("Scripting.FileSystemObject")
MkDir ThisWorkbook.Path & "\生成文件"           '创建文件夹
s = Application.GetOpenFilename(FileFilter:="word文件,*.doc*", MultiSelect:=False)
If s = "False" Then Exit Sub
For i = 2 To Range("a" & Rows.Count).End(xlUp).Row
    FileCopy s, _
    ThisWorkbook.Path & "\生成文件\" & MyFile.GetBaseName(s) & "-" & Range("A" & i) & ".docx"
Next
MsgBox "OK"
End Sub