Question

我需要一个用于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描述：权限被拒绝

如何解决错误？

Answer 1

您需要将来自.Sections(1).Index属性的Integer转换为字符串。两个建议：

.Name = Cstr(strWMName)

或

.Name = "WaterMarkName" & strWMName

请记住在RemoveWaterMark子程序中相应更改。

尝试根据文件名

1 个答案: