Word 2010 Macro to Insert Text Box w/Draft Stamp

Topic

New Reply

I have a macro that inserts a draft stamp in my first page header. However, I would like to convert this to a Text Box. I’ve searched in this forum as well as across the web to see if I could figure out how to insert a text box, format it, and insert the appropriate text. I’ve located some snippets, but now I’m confused (lost). Maybe somebody has done something like this already and can point me in the right direction?

So far, I’ve come up with this:

Set Box = ActiveDocument.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=400, Top:=30, Width:=200, Height:=100)
Box.TextFrame.TextRange.Font.Name = “Calibri”
Box.TextFrame.TextRange.Font.Size = 14
Box.TextFrame.TextRange.Font.Bold = Yes
Box.TextFrame.TextRange.Text = DraftWord + DraftNum + ” ”
Box.TextFrame.TextRange.InsertSymbol CharacterNumber:=8212, Unicode:=True
Box.TextFrame.TextRange.InsertDateTime DateTimeFormat:=”MM/dd/yyyy”, InsertAsField:=False

I have code that works before the above code to ask if this is a blacklined draft or not and the draft number (which appear in the 7th line). The macro works up to this point. However, I want the text to be formatting like this:

Wells Fargo Draft #1 — 2014-11-24
FOR DISCUSSION PURPOSES ONLY

The double-hyphen in the above is supposed to be an en dash but I wasn’t sure how to insert that here. The font sizes would be different each line as well. The problem with my macro code is that after it inserts Draft Word etc. and I try to insert more, it just ovewrites what’s in the box already. Any thoughts on this?

I’ve poked around to find out how to modify position & line color, but have struck out on that. Any suggestions?

Last, I would like the macro to be able to find an existing textbox, delete it, then insert the new one. How do I name a TextBox so that I can select the same one each time? I tried bookmarks, but that didn’t seem to work. It only worked with the text in the TextBox.

Thanks!!

-Rich

Reply | Quote

Replies

Floating objects in a header are difficult to manage in vba because all objects (according to vba) are in section 1 header despite actually appearing in different headers. Since you only want the stamp on a single page, I would recommend you put it on the page rather than in a header. This keeps the code much simpler.

In the past, I have used the ‘Alternative Text’ property as a method of identifying floating objects. Although this has all been superceded by the built-in Watermarking I still have code which used to be useful and may help you achieve your aims.

Code:

'========================================================
Sub Watermarker()
'Prompts the user to input the watermark text and then creates it
Dim iView As Integer
Dim sWarning As String, sWord As String
Dim aShape As Shape
Dim aHeader As HeaderFooter, aSect As Section

With ActiveWindow
  iView = .ActivePane.View.Type
  If .View.SplitSpecial  wdPaneNone Then .Panes(2).Close
  .ActivePane.View.Type = wdPageView
  .ActivePane.View.SeekView = wdSeekCurrentPageHeader
End With

'If there is already watermarks added by this macro then delete them
  For Each aShape In ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
    If Left(aShape.Name, 9) = "Watermark" Then aShape.Delete
  Next aShape

'Gets user input to type the word to use as a watermark
sWarning = "Please type in the word you want watermarked!" & vbCr & _
            "Click CANCEL to not add a Watermark"
sWord = InputBox(sWarning, "Watermarker", "D R A F T")
If sWord = "" Then Exit Sub 'If the user clicked cancel end the macro

For Each aSect In ActiveDocument.Sections
  For Each aHeader In aSect.Headers
    If aHeader.Exists And Not aHeader.LinkToPrevious Then
      aHeader.Range.Select
      Set aShape = aHeader.Shapes.AddTextEffect(msoTextEffect13, sWord, _
      "Arial Black", 80#, msoFalse, msoTrue, 144.95, 139.1)
      aShape.Fill.ForeColor.RGB = RGB(180, 180, 180)
      aShape.Fill.Visible = msoTrue
      aShape.Fill.Solid
      aShape.Shadow.Visible = msoFalse
      aShape.IncrementRotation -30#
      If aShape.Width > PointsToCentimeters(16) Then
        aShape.Width = CentimetersToPoints(16)
      End If
      aShape.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
      aShape.RelativeVerticalPosition = wdRelativeVerticalPositionPage
      aShape.Left = (aSect.PageSetup.PageWidth - aShape.Width) / 2
      aShape.Top = (aSect.PageSetup.PageHeight - aShape.Height) / 2
      aShape.Name = "Watermark " & aSect.Index & "-" & aHeader.Index
    End If
  Next aHeader
Next aSect

ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
ActiveWindow.ActivePane.View.Type = iView

End Sub

Reply | Quote

Thanks for the suggestions, Andrew. I may have mislead you (and others). I don’t want the draft stamp in the header. That’s what I do now, just with text. I want to convert to using a floating text box on the first page only. I have continued to poke around the web searching for macros with TextFrame in them and found some good stuff. This is what my draft stamp looks like so far:

38527-DraftStamp

This is the code I’ve come up with so far:

Code:

Sub CtrlMPeriod()
    Dim DraftNum As String
    Dim DraftWord As String
    Dim Result
    Dim TrackChanges
    Dim vBox As Shape
    Dim CurrentDate As String
        
    CurrentDate = Format(Now(), “yyyy-mm-dd”)
            
    If ActiveDocument.TrackRevisions = True Then
        ActiveDocument.TrackRevisions = False
        TrackChanges = 1
    Else
        TrackChanges = 0
    End If
    
    Result = MsgBox(“Redlined draft?”, vbYesNo + vbQuestion)
    If Result = 6 Then DraftWord = “Wells Fargo Redlined Draft #” Else DraftWord = “Wells Fargo Draft #”
    DraftNum = InputBox$(“Enter draft number.”)
    If ActiveWindow.View.SplitSpecial  wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Or ActiveWindow.ActivePane.View.Type _
         = wdMasterView Then
        ActiveWindow.ActivePane.View.Type = wdPageView
    End If
    
    On Error GoTo SkipBox
    ActiveDocument.Shapes(1).Delete
    
SkipBox:
    
    Set vBox = ActiveDocument.Shapes.AddTextbox( _
        Orientation:=msoTextOrientationHorizontal, _
        Left:=InchesToPoints(4.7), Top:=InchesToPoints(0.3), _
        Width:=InchesToPoints(3.5), Height:=InchesToPoints(0.5))
    
    With vBox
        .LockAspectRatio = msoFalse
        .LockAnchor = False
        .TextFrame.AutoSize = True
        .TextFrame.WordWrap = False
        .Line.Weight = 2
    End With
    
    With vBox.TextFrame.TextRange
        .Font.Name = “Calibri”
        .Font.Size = 12
        .Font.Bold = True
        .Paragraphs.Alignment = wdAlignParagraphCenter
        .Text = DraftWord + DraftNum + ” — ” + CurrentDate _
            + vbCr + “FOR DISCUSSION PURPOSES ONLY”
    End With
       
    If TrackChanges = 1 Then ActiveDocument.TrackRevisions = True
    
End Sub

This is far from final. I’m working with my header macro code and some of that is mostly inapplicable. I probably need to go get my code that saves a bookmark, goes to the top of the file, inserts the textbox, and then jumps back to the bookmark, but I’ll add that later.

In any event, what I can’t figure out is how to select the formatting options for the text box. I’ve been using TextFrame, but maybe I need to use Shapes per your code? I want it to have a red border and be shaded. Is there a way to select this formatting option from the ribbon bar, maybe with some type of “style” selection?

38528-BoxStyle

And what about shadow? I’d like to apply this shadow:

38529-Shadow

I’m going to keep poking around, but if you have any quick suggestions, that would be great.

When I’m done, I’ll post all my code here for others to use in case someone has the same issues.

Thanks!

Reply | Quote

Oh, and I have one more issue: How do I change the formatting of the second line (paragraph) in the text box? I can set the formatting for all of it, but if I use TextRange.Text, it overwrites what’s already in there. I suppose there’s some way to select the empty text in the box and use selection.text instead to insert text and format it rather than using a range. Any suggestions on how to do this?

I will keep poking around here and the web to see if I can find anything, but if anyone has the quick answer that would be great.

Thanks.

Reply | Quote

I still have one issue, but I think I’ve resolved just about all my other issues. Here is what my draft stamp looks like now:

38530-TextBox2

Here is my code:

Code:

Sub CtrlMPeriod()
‘
‘ Ctrl+M,. — Draft Stamp 2014-11-26
‘
    Dim DraftNum As String
    Dim DraftWord As String
    Dim Result
    Dim TrackChanges
    Dim vBox As Shape
‘    Dim vShape As Shape    ‘Used with code to delete ALL Shapes in Doc
    Dim myShape As Shape, tmp As Shape  ‘Used with code to delete specific Text Box
    Dim vLeftMargin As String
          
    If ActiveDocument.TrackRevisions = True Then
        ActiveDocument.TrackRevisions = False
        TrackChanges = 1
    Else
        TrackChanges = 0
    End If
    
    Result = MsgBox(“Redlined draft?”, vbYesNo + vbQuestion)
    If Result = 6 Then
        DraftWord = “Wells Fargo Redlined Draft #”
        vLeftMargin = “4.9”
    Else
        DraftWord = “Wells Fargo Draft #”
        vLeftMargin = “5.5”
    End If
    
    DraftNum = InputBox$(“Enter draft number.”)
    
    If ActiveWindow.View.SplitSpecial  wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Or ActiveWindow.ActivePane.View.Type _
         = wdMasterView Then
        ActiveWindow.ActivePane.View.Type = wdPageView
    End If
    
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    
    ‘Set bookmark to return to after macro completes
    With ActiveDocument.Bookmarks
        .Add Range:=Selection.Range, Name:=”ReturnHere”
        .DefaultSorting = wdSortByName
        .ShowHidden = False
    End With

    For Each tmp In ActiveDocument.Shapes   ‘Searches collection for named text box
        If LCase(tmp.Name) = “drafttextbox1” Then
            Set myShape = tmp
            Exit For
        End If
    Next
    
    If Not (myShape Is Nothing) Then    ‘If collection is not empty, then deletes text box
        myShape.Delete
    End If
    
‘    For Each vShape In ActiveDocument.Shapes    ‘Deletes all Text Boxes
‘        If vShape.Type = msoTextBox Then vShape.Delete
‘    Next vShape
    
    Set vBox = ActiveDocument.Shapes.AddTextbox( _
        Orientation:=msoTextOrientationHorizontal, _
        Left:=InchesToPoints(vLeftMargin), Top:=InchesToPoints(0.25), _
        Width:=InchesToPoints(3.5), Height:=InchesToPoints(0.5))
    
    With vBox
        .Name = “DraftTextBox1”
        .LockAspectRatio = msoFalse
        .LockAnchor = True
        .TextFrame.AutoSize = True
        .TextFrame.WordWrap = False
‘        .ShapeStyle = msoLineStylePreset3  ‘Didn’t work in all docs
        .Line.Weight = 2
        .Line.ForeColor = RGB(190, 75, 72)
        With .Shadow
            .Style = msoShadowStyleOuterShadow
            .Size = 100
            .Blur = 8.5
            .Visible = msoTrue
        End With
    End With
    
    With vBox.TextFrame.TextRange
        .Font.Name = “Calibri”
        .Font.Size = 12
        .Font.Bold = True
        .Paragraphs.Alignment = wdAlignParagraphCenter
        .Text = DraftWord + DraftNum + ” — ” + Format(Now(), “yyyy-mm-dd”) _
            + vbCr + “FOR DISCUSSION PURPOSES ONLY”
    End With
    
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    
    On Error GoTo SkipBookMark
    Selection.GoTo What:=wdGoToBookmark, Name:=”ReturnHere”
    ActiveDocument.Bookmarks(“ReturnHere”).Delete
    With ActiveDocument.Bookmarks
        .DefaultSorting = wdSortByName
        .ShowHidden = False
    End With
    
SkipBookMark:
    If TrackChanges = 1 Then ActiveDocument.TrackRevisions = True
    
End Sub

The only thing I haven’t been able to figure out in formatting the text in the text box. I can insert one font & point size, but I can’t adjust these for the second line. It may look fine the way it is, but if there’s a way to adjust it, I’d like to know for future reference. Thanks.

Reply | Quote

Late in your code you are adding the content of the text box. If you want to format the second paragraph you can do this after you have added that paragraph eg

Code:

    With vBox.TextFrame.TextRange
        .Font.Name = "Calibri"
        .Font.Size = 12
        .Font.Bold = True
        .Paragraphs.Alignment = wdAlignParagraphCenter
        .Text = DraftWord + DraftNum + " -- " + Format(Now(), "yyyy-mm-dd") _
            + vbCr + "FOR DISCUSSION PURPOSES ONLY"
        [B].Paragraphs(2).Range.Font.Size = 18[/B]
    End With

Reply | Quote

Fantastic. Thanks for the tip. I tried something like .Paragraphs after scouring the web, but couldn’t get it to work. Must have had my syntax wrong (obviously). Thanks.

Reply | Quote