当前位置：首页 > news >正文

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

news 2025/6/29 14:11:19

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

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


Sub 宏1()Dim MyDialog As FileDialogDim GetStr As String, Adoc As StringDim PsDoc As DocumentApplication.ScreenUpdating = FalseSet MyDialog = Application.FileDialog(msoFileDialogFolderPicker)If MyDialog.Show Then GetStr = MyDialog.SelectedItems(1) Else Exit SubAdoc = Dir(GetStr & "\*.doc*")Do While Adoc <> ""    '如果是文件夹,或者没有此文件,则会返回""Set PsDoc = Documents.Open(GetStr & "\" & Adoc) '打开指定文档On Error Resume NextActiveDocument.Sections(1).Range.SelectActiveWindow.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).SelectSelection.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 = wdSeekMainDocumentActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeaderSelection.Style = ActiveDocument.Styles("正文")ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocumentPsDoc.Close TrueAdoc = Dir()LoopApplication.ScreenUpdating = True
End Sub

以下代码是excel运行的代码

Option ExplicitSub 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).RowFileCopy s, _ThisWorkbook.Path & "\生成文件\" & MyFile.GetBaseName(s) & "-" & Range("A" & i) & ".docx"
Next
MsgBox "OK"
End Sub