[ms office - 2010] Word 2010 Macros

[featured_spectre]

Some useful ones I've done recently

 

Print Preview (not through file print way)

Sub PrintPreviewEditMode()
ActiveDocument.PrintPreview
ActiveWindow.View.Zoom = 100
End Sub

 

Add Draft Watermark (or any other, just swap out draft for any other word)

Sub InsertDraftWaterMark()
Dim oSection As Section
Dim oHeader As HeaderFooter
Dim oRng As Range
Dim oShape As Shape
   For Each oSection In ActiveDocument.Sections
       For Each oHeader In oSection.Headers
           If oHeader.Exists Then
               Set oRng = oHeader.Range
               oRng.End = oRng.Paragraphs(1).Range.End - 1
               For Each oShape In oRng.ShapeRange
                   If oShape.Type = 15 Then oShape.Delete
               Next oShape
           End If
       Next oHeader
   Next oSection
   ActiveDocument.Sections(1).Range.Select
   ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
   Selection.HeaderFooter.Shapes.AddTextEffect( _
       PowerPlusWaterMarkObject, "DRAFT", "Calibri", 1, False, False, _
       0, 0).Select
   Selection.ShapeRange.Name = "PowerPlusWaterMarkObject"
   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(8.42)
   Selection.ShapeRange.Width = CentimetersToPoints(14.03)
   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

 

Remove Watermarks

Sub RemoveWaterMark()
Dim oSection As Section
Dim oHeader As HeaderFooter
Dim oRng As Range
Dim oShape As Shape
   For Each oSection In ActiveDocument.Sections
       For Each oHeader In oSection.Headers
           If oHeader.Exists Then
               Set oRng = oHeader.Range
               oRng.End = oRng.Paragraphs(1).Range.End - 1
               For Each oShape In oRng.ShapeRange
                   If oShape.Type = 15 Then oShape.Delete
               Next oShape
           End If
       Next oHeader
   Next oSection
End Sub

 

Just thought I'd share