Word Macro to insert Watermark

At work we have a service that generates Word documents to send out to customers. The documents are generated by combining paragraphs of text to make a single document. When a paragraph is changed any document that references it must be checked to make sure that the change has been made correctly and the layout of the document is still correct.

Normally the UAT department will go through each document to check that it's correct. This is ok until a change is made to a common paragraph that effects several documents. A while back somebody asked if we could automatically generate every single document and add a watermark to it to indicate which document it was once printed.

Below is the VBA code written to automatically add a watermark to a document (or in this case every open document).  The CreateDictionary is basically a sub that populates a global dictionary with every possible filename and it's description - an SQL statement is used to pull out all the document names/description combinations.

Sub AddWaterMarks()

    Dim liCounter As Integer
    Dim liUnderScorePos As Integer
    Dim lsDocName As String
    Dim lsWatermarkText As String
    
    CreateDictionary
    
    For liCounter = 1 To Documents.Count          
        lsDocName = Documents(liCounter).Name        
        liUnderScorePos = InStr(lsDocName, "_")        
        If liUnderScorePos > 0 Then            
            lsDocName = Mid$(lsDocName, 1, liUnderScorePos - 1)            
            Documents(liCounter).Activate                    
            lsWatermarkText = gDict(lsDocName)            
            InsertWaterMark lsDocName & " - " & lsWatermarkText                    
        End If            
    Next liCounter
    
    MsgBox "Done!", vbInformation + vbOKOnly, "Document Watermarker"
    
End Sub

Sub InsertWaterMark(TextToInsert As String)

    ActiveDocument.Sections(1).Range.Select
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.HeaderFooter.Shapes.AddTextEffect(msoTextEffect1 _
        , TextToInsert, "Calibri", 1, _
         False, False, 0, 0).Select
    Selection.ShapeRange.TextEffect.NormalizedHeight = False
    Selection.ShapeRange.Line.Visible = False
    Selection.ShapeRange.Fill.Visible = True
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(192, 192, 192)
    Selection.ShapeRange.Fill.Transparency = 0.5
    Selection.ShapeRange.Rotation = 315
    Selection.ShapeRange.LockAspectRatio = True
    Selection.ShapeRange.Height = CentimetersToPoints(3.06)
    Selection.ShapeRange.Width = CentimetersToPoints(19.38)
    Selection.ShapeRange.WrapFormat.AllowOverlap = True
    Selection.ShapeRange.WrapFormat.Side = wdWrapNone
    Selection.ShapeRange.WrapFormat.Type = 3
    Selection.ShapeRange.RelativeHorizontalPosition = _
        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.RelativeVerticalPosition = _
        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.Left = wdShapeCenter
    Selection.ShapeRange.Top = wdShapeCenter
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    
End Sub

So hopefully now I've blogged it next time my normal.dot gets blasted away I'll have a backup of at least one macro I've written :-)