我需要一个用于Word 2013的'自动运行'VBA来添加或删除取决于文档文件名的水印。我想将此添加到我们用于技术报告的模板中,而模板又由外部应用程序/系统生成并在流程中自动命名。因此,相同的文档模板可能会根据工作流程的不同而命名
对于标题为“DRAFT.XXX.NNNNNNNN ..”的文档,我想要一个'草稿'水印 对于任何其他文件,应该没有水印(或水印可以是白色,即不可见)
我已成功创建VBA /宏以插入或删除水印:
Sub InsertWaterMark()
Dim strWMName As String
On Error GoTo ErrHandler
'selects all the sheets
ActiveDocument.Sections(1).Range.Select
strWMName = ActiveDocument.Sections(1).Index
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
'Change the text for your watermark here
Selection.HeaderFooter.Shapes.AddTextEffect(msoTextEffect1, _
"DRAFT", "Arial", 1, False, False, 0, 0).Select
With Selection.ShapeRange
.Name = strWMName
.TextEffect.NormalizedHeight = False
.Line.Visible = False
With .Fill
.Visible = True
.Solid
.ForeColor.RGB = Gray
.Transparency = 0.5
End With
.Rotation = 315
.LockAspectRatio = True
.Height = InchesToPoints(2.42)
.Width = InchesToPoints(6.04)
With .WrapFormat
.AllowOverlap = True
.Side = wdWrapNone
.Type = 3
End With
.RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
'If using Word 2000 you may need to comment the 2
'lines above and uncomment the 2 below.
' .RelativeHorizontalPosition = wdRelativeVerticalPositionPage
' .RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Left = wdShapeCenter
.Top = wdShapeCenter
End With
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Selection.Collapse Direction:=wdCollapseEnd
Exit Sub
ErrHandler:
MsgBox "An error occured trying to insert the watermark." & Chr(13) & _
"Error Number: " & Err.Number & Chr(13) & _
"Decription: " & Err.Description, vbOKOnly + vbCritical, "Error"
End Sub
Sub RemoveWaterMark()
Dim strWMName As String
On Error GoTo ErrHandler
ActiveDocument.Sections(1).Range.Select
strWMName = ActiveDocument.Sections(1).Index
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.HeaderFooter.Shapes(strWMName).Select
Selection.Delete
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Selection.Collapse Direction:=wdCollapseEnd
Exit Sub
ErrHandler:
'MsgBox "An error occured trying to remove the watermark." & Chr(13) & _
'"Error Number: " & Err.Number & Chr(13) & _
'"Decription: " & Err.Description, vbOKOnly + vbCritical, "Error"
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Selection.Collapse Direction:=wdCollapseEnd
End Sub
我创建了一个AutoOpen宏,用于检查"DRAFT"
,"Draft"
或"draft"
文档的前五个字符,然后调用相应的子例程:
Sub AutoOpen()
Dim oldfilename As String
Dim draft As String
oldfilename = ActiveDocument.Name
draft = Left(oldfilename, 5)
Select Case draft
Case "DRAFT", "Draft", "draft"
Call InsertWaterMark
Case Else
Call RemoveWaterMark
End Select
Exit Sub
但是当代码分支到InsertWatermark子例程和行
时,我收到错误.Name = strWMName
然后我收到错误:
尝试插入水印时发生错误。错误号码:70描述:权限被拒绝
如何解决错误?
答案 0 :(得分:0)
您需要将来自.Sections(1).Index
属性的Integer转换为字符串。两个建议:
.Name = Cstr(strWMName)
或
.Name = "WaterMarkName" & strWMName
请记住在RemoveWaterMark
子程序中相应更改。