Results 1 to 7 of 7
  1. #1
    3 Star Lounger rcbjr2's Avatar
    Join Date
    Jan 2001
    Location
    Matthews, NC
    Posts
    279
    Thanks
    6
    Thanked 1 Time in 1 Post

    Word 2010 Macro to Insert Text Box w/Draft Stamp

    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

  2. #2
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,852
    Thanks
    4
    Thanked 259 Times in 239 Posts
    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
    Andrew Lockton, Chrysalis Design, Melbourne Australia

  3. #3
    3 Star Lounger rcbjr2's Avatar
    Join Date
    Jan 2001
    Location
    Matthews, NC
    Posts
    279
    Thanks
    6
    Thanked 1 Time in 1 Post
    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:

    DraftStamp.jpg

    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?

    BoxStyle.jpg

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

    Shadow.jpg

    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!

  4. #4
    3 Star Lounger rcbjr2's Avatar
    Join Date
    Jan 2001
    Location
    Matthews, NC
    Posts
    279
    Thanks
    6
    Thanked 1 Time in 1 Post
    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.

  5. #5
    3 Star Lounger rcbjr2's Avatar
    Join Date
    Jan 2001
    Location
    Matthews, NC
    Posts
    279
    Thanks
    6
    Thanked 1 Time in 1 Post
    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:

    TextBox2.jpg

    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.

  6. #6
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,852
    Thanks
    4
    Thanked 259 Times in 239 Posts
    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"
            .Paragraphs(2).Range.Font.Size = 18
        End With
    Andrew Lockton, Chrysalis Design, Melbourne Australia

  7. The Following User Says Thank You to Andrew Lockton For This Useful Post:

    rcbjr2 (2014-11-26)

  8. #7
    3 Star Lounger rcbjr2's Avatar
    Join Date
    Jan 2001
    Location
    Matthews, NC
    Posts
    279
    Thanks
    6
    Thanked 1 Time in 1 Post
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •