I am seeking a way to insert a watermark into Word documents. Here is the code I get by recording Macros,
Sub add_watermark()
'
' Macro2 Macro
'
'
ActiveDocument.Sections(1).Range.Select
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.HeaderFooter.Shapes.AddTextEffect( _
PowerPlusWaterMarkObject354239640, "PAID", "arial", 1, False, False, 0, 0 _
).Select
Selection.ShapeRange.Name = "PowerPlusWaterMarkObject354239640"
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
Selection.ShapeRange.Rotation = 315
Selection.ShapeRange.LockAspectRatio = True
Selection.ShapeRange.Height = CentimetersToPoints(9.31)
Selection.ShapeRange.Width = CentimetersToPoints(13.96)
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
But I have an "out of range" error after running the Macro in another document. When I debug it, this line
"Selection.ShapeRange.Name = "PowerPlusWaterMarkObject354239640" is highlighted.
Does anyone know how to tackle it?
Thanks,
Try something based on:
Sub AddPaidWatermark()
Application.ScreenUpdating = False
Dim sWdth As Single, Shp As Shape
With ActiveDocument.Sections(1)
With .PageSetup
sWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
With .Headers(wdHeaderFooterPrimary)
If .Range.Characters.First.Information(wdWithInTable) = True Then
With .Range.Tables(1)
.Rows.Add .Rows(1)
.Split .Rows(2)
End With
.Range.Tables(1).Delete
.Range.Paragraphs(1).Range.Font.Hidden = True
End If
Set Shp = .Shapes.AddTextEffect(msoTextEffect1, "PAID", "Arial", 1, False, False, 0, 0)
End With
With Shp
.WrapFormat.Type = wdWrapBehind
.ZOrder msoBringToFront
.Height = sWdth / 2 ^ 0.5
.Width = .Height
.Rotation = 315
.RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Left = wdShapeCenter
.Top = wdShapeCenter
With .Fill
.Visible = True
.Solid
.ForeColor.RGB = RGB(192, 192, 192)
End With
End With
End With
Application.ScreenUpdating = True
End Sub
Related
I want to add, via VBA in MS Word, a Textbox at the current cursor position.
This works but if the cursor is located within a table (whatever cell), a Textbox gets added in the wrong location.
Sub AddTextBox()
Dim oShape As Shape
Dim x As Long
Dim y As Long
'get Cursorposition
x = Selection.Information(wdHorizontalPositionRelativeToPage)
y = Selection.Information(wdVerticalPositionRelativeToPage)
Set oShape = ActiveDocument.Shapes.AddTextBox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=x, Top:=y, Width:=200, Height:=12)
With oShape
With .TextFrame
With .TextRange
.Text = "TEXT"
.Font.Name = "Segoe Script"
.Font.Size = 10
.Font.ColorIndex = wdRed
.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
.MarginBottom = Application.CentimetersToPoints(0.15)
.MarginTop = Application.CentimetersToPoints(0.15)
.MarginLeft = Application.CentimetersToPoints(0.1)
.MarginRight = Application.CentimetersToPoints(0.1)
.WordWrap = False
.AutoSize = True
End With
.LockAnchor = False
.WrapFormat.Type = wdWrapNone
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
.Height = Application.CentimetersToPoints(0.8)
End With
End Sub
How do I place the TextBox at the cursor position, when the cursor is placed in a table?
When you add a shape the position defaults to being relative to the margin, so you need to set the required relative position after you have added the shape.
Sub AddTextBox()
Dim oShape As Shape
Dim x As Long
Dim y As Long
'get Cursorposition
x = Selection.Information(wdHorizontalPositionRelativeToPage)
y = Selection.Information(wdVerticalPositionRelativeToPage)
Set oShape = ActiveDocument.Shapes.AddTextBox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=x, Top:=y, Width:=200, Height:=12, Anchor:=Selection.Range)
With oShape
.LeftRelative = wdRelativeHorizontalPositionPage
.TopRelative = wdRelativeVerticalPositionPage
.LockAnchor = False
.WrapFormat.Type = wdWrapNone
With .TextFrame
With .TextRange
.Text = "TEXT"
.Font.Name = "Segoe Script"
.Font.Size = 10
.Font.ColorIndex = wdRed
.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
.MarginBottom = Application.CentimetersToPoints(0.15)
.MarginTop = Application.CentimetersToPoints(0.15)
.MarginLeft = Application.CentimetersToPoints(0.1)
.MarginRight = Application.CentimetersToPoints(0.1)
.WordWrap = False
.AutoSize = True
End With
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
.Height = Application.CentimetersToPoints(0.8)
End With
End Sub
I have the following function, which I intended to create a shape:
Public Function LinkToAddInfo(ShapeName As String, BoxName As String, DisplayNumber As Long, AddName As String, TrueNumber As Long) As Shape
Dim ShapeName As Shape
Set ShapeName = .Shapes.AddShape(msoShapeRoundedRectangle, 640, 470, 71, 27)
With ShapeName
.Fill.ForeColor.RGB = RGB(191, 191, 191)
.Fill.Transparency = 0
.Name = BoxName
With .Line
.Weight = 0
.ForeColor.RGB = RGB(191, 191, 191)
.Transparency = 0
End With ' Outline
With .TextFrame.TextRange
.Text = "Add. Info " & DisplayNumber & vbNewLine & AddName
With .Font
.Name = "Arial"
.Size = 8
.Bold = msoTrue
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.RGB = RGB(255, 255, 255)
End With ' Font
End With ' TextFrame
End With ' Square itself
End Function
I tried to call it from within a module using:
LinkToAddInfo("tiny1", "Yedinfo1", DisplayNumber, AddName, AddNumber)
But it throws an error (the code is shown in red within the editor).
When I have all the code within the module itself, it works fine. I'm just struggling to transcribe it into an external function (which I want to do so that I don't have to repeat this code again and again).
How can I achieve this?
You have several problems with this.
You don't need a Function for this, since you aren't returning data to the program. Instead, use a Sub.
The first argument is a string, but then you try to use the same variable name in a declaration as a shape. But you don't use the string argument for anything, so it can be deleted. You also don't use TrueNumber, so that can be taken out.
To access a slide master, you need to use Designs with a numeric argument, not SlideMaster.
The following should do what you want:
Public Sub LinkToAddInfo(BoxName As String, DisplayNumber As Long, AddName As String)
Dim oShape As Shape
Set oShape = ActivePresentation.Designs(1).SlideMaster.Shapes.AddShape(msoShapeRoundedRectangle, 640, 470, 71, 27)
With oShape
.Fill.ForeColor.RGB = RGB(191, 191, 191)
.Fill.Transparency = 0
.Name = BoxName
With .Line
.Weight = 0
.ForeColor.RGB = RGB(191, 191, 191)
.Transparency = 0
End With ' Outline
With .TextFrame.TextRange
.Text = "Add. Info " & DisplayNumber & vbNewLine & AddName
With .Font
.Name = "Arial"
.Size = 8
.Bold = msoTrue
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.RGB = RGB(255, 255, 255)
End With ' Font
End With ' TextFrame
End With ' Square itself
End Sub
```
I am doing a document using a userform. In the userform I setup radiobuttons when clicked I want the text from a macro that I did to be inserted at a specific bookmark in my document. Help please
This is my macro:
Sub ordonnance()
'
' ORDONNANCE Macro
'
'
Dim bmSignet As Bookmark
Dim rgPlageDuSignet As Range
Set bmSignet = ActiveDocument.Bookmarks("ORDONNANCE_DE")
Set rgPlageDuSignet = bmSignet.Range
rgPlageDuSignet.Select
ActiveDocument.Tables.Add rgPlageDuSignet, 1, 1
With Selection.Tables(1)
If .Style <> "Grille du tableau" Then
.Style = "Grille du tableau"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="ORDONNANCE DE NON-PUBLICATION ..."
Set bmSignet = Nothing
Set rgPlageDuSignet = Nothing
End Sub
This is my radiobutton:
Private Sub OptionButton3_Click()
If Me.OptionButton3.Value = True Then
Call RemplaceSignet("ORDONNANCE_DE", "ORDONNANCE DE NON-PUBLICATION ...")
Else
Call RemplaceSignet("ORDONNANCE_DE", " ")
End If
End Sub
Try:
Sub ordonnance(StrBkMk As String, StrTxt As String)
'
' ORDONNANCE Macro
'
'
Dim Tbl As Table
With ActiveDocument
Set Tbl = .Tables.Add(.Bookmarks(StrBkMk).Range, 1, 1)
With Tbl
.Style = "Grille du tableau"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
With .Cell(1, 1).Range
With .Font
.Name = "Arial"
.Size = 12
.Bold = True
End With
.Text = StrTxt
End With
End With
End With
Set Tbl = Nothing
End Sub
Note that there is no need to select anything.
I have the following macro and I wish to loop the following program for 500 charts starting from 1.
Sub Arrow()
'
' Arrow Macro
'
' Keyboard Shortcut: Ctrl+q
'
ActiveSheet.ChartObjects("Chart 459").Activate
ActiveChart.FullSeriesCollection(1).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(192, 0, 0)
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.Weight = 2.5
End With
Selection.Format.Line.EndArrowheadStyle = msoArrowheadTriangle
With Selection.Format.Line
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWide
End With
ActiveChart.FullSeriesCollection(2).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent5
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.5
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.Weight = 2.5
End With
Selection.Format.Line.EndArrowheadStyle = msoArrowheadTriangle
With Selection.Format.Line
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWide
End With
End Sub
I agree with #Jeeped. What you want is not difficult. However, moving from Select etc to Index based takes some learning.
the code below should do what you want. It worked for me in Office 2010, which uses SeriesCollection(1) instead of FullSeriesCollection(1)
Sub Arrow() ' ' Arrow Macro ' ' Keyboard Shortcut: Ctrl+q ' ActiveSheet.ChartObjects("Chart 459").Activate
Dim i As Long
Dim cht As Chart
For i = 1 To ActiveWorkbook.Charts.Count
Set cht = ActiveWorkbook.Charts(i)
With cht.FullSeriesCollection(1).Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(192, 0, 0)
.Transparency = 0
.Weight = 2.5
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWide
End With
With cht.FullSeriesCollection(2).Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent5
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.5
.Transparency = 0
.Visible = msoTrue
.Weight = 2.5
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWide
End With
Next i
End Sub
Now you know how to use a For Loop and Index based references.
I am having problems getting my pictures to wrap behind the text in Word 2003 using VBA. I can use all the other wrapping options fine but when I try and use wdWrapBehind I get the following error.
"Compile Error: Variable not defined"
I have had a hunt around through google with no luck.
Code:
Dim shape1 As shape
Dim imagePath1 As String
imagePath1 = "C:\image.jpg"
Set shape1 = ActiveDocument.Shapes.AddPicture(imagePath1)
With shape1
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoCTrue
.LockAspectRatio = msoTrue
.WrapFormat.Type = wdWrapBehind
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Left = InchesToPoints(0.433)
.Top = InchesToPoints(0.413)
End With
Any help appreacited!
Cheers,
Michael
Managed to get it to work by adding these 4 lines instead of wdWrapBehind.
.WrapFormat.AllowOverlap = True
.WrapFormat.Side = wdWrapBoth
.WrapFormat.Type = 3
.ZOrder 5
Full code:
Dim shape1 As shape
Dim imagePath1 As String
imagePath1 = "C:\image.jpg"
Set shape1 = ActiveDocument.Shapes.AddPicture(imagePath1)
With shape1
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoCTrue
.WrapFormat.AllowOverlap = True
.WrapFormat.Side = wdWrapBoth
.LockAspectRatio = msoTrue
.WrapFormat.Type = 3
.ZOrder 5
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Left = InchesToPoints(6.889)
.Top = InchesToPoints(0.374)
End With