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
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 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
I have a code which creates charts.I want to create this chart on a specific worksheet named as "Charts" with a particular location A5:F18.My code is given below:
Sub Macro1()
Dim i As Long
Range("B5:E5").Offset(i).Select
With ActiveSheet.Shapes.AddChart
With .Chart
.ChartType = xlColumnClustered
.SetSourceData Source:=Range("Pivot!$A$3:$E$5").Offset(i)
.SeriesCollection(1).ApplyDataLabels
.SeriesCollection(2).ApplyDataLabels
.SeriesCollection(3).ApplyDataLabels
.ShowValueFieldButtons = False
.HasTitle = True
.ChartTitle.Text = "Consolidated"
End With
.Name = "chart" & Format(i + 1, "000")
.Width = 288
.LockAspectRatio = msoTrue
End With
End Sub
I am not be able to create that chart on that particular worksheet with this particular location. How to do that?
you can try this:
With ActiveSheet.Shapes.AddChart
With .Chart
.ChartType = xlColumnClustered
.SetSourceData Source:=Range("Pivot!$A$3:$E$5").Offset(i)
.SeriesCollection(1).ApplyDataLabels
.SeriesCollection(2).ApplyDataLabels
.SeriesCollection(3).ApplyDataLabels
.ShowValueFieldButtons = False
.HasTitle = True
.ChartTitle.Text = "Consolidated"
End With
.Name = "chart" & Format(i + 1, "000")
.Top = Range("Pivot!$A$5:$F$18").Top
.Left = Range("Pivot!$A$5:$F$18").Left
.Width = Range("Pivot!$A$5:$F$18").Width
.Height = Range("Pivot!$A$5:$F$18").Height
.LockAspectRatio = msoTrue
End With
I am setting up a macro to generate a chart. I have recorded a macro while I was generating the sample chart, but now I need to have the macro working independently from the name of the chart (Chart 9 in this case)
Sheets("statistics").Select
Sheets("statistics").Range("A101:C106").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlColumnStacked
ActiveChart.SetSourceData Source:=Range("statistics!$A$101:$C$106")
ActiveChart.ChartArea.Select
ActiveSheet.Shapes("Chart 9").Name = "waterfall"
ActiveChart.Location Where:=xlLocationAsObject, Name:="summary"
ActiveSheet.ChartObjects("waterfall").Activate
ActiveSheet.Shapes("waterfall").IncrementLeft 80
ActiveSheet.Shapes("waterfall").IncrementTop -2200
ActiveSheet.ChartObjects("waterfall").Activate
ActiveSheet.Shapes("waterfall").ScaleWidth 1.6025463692, msoFalse, msoScaleFromTopLeft
ActiveSheet.Shapes("waterfall").ScaleHeight 1.6084106153, msoFalse, msoScaleFromTopLeft
ActiveSheet.ChartObjects("waterfall").Activate
ActiveChart.Legend.Select
Selection.Delete
ActiveSheet.ChartObjects("waterfall").Activate
ActiveChart.SeriesCollection(1).Select
Selection.Format.Fill.Visible = msoFalse
ActiveChart.SeriesCollection(2).Select
ActiveChart.SeriesCollection(2).Points(6).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent3
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Solid
End With
ActiveChart.SeriesCollection(2).Points(1).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent3
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Solid
End With
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
ActiveChart.SeriesCollection(2).Points(5).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Solid
End With
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With
ActiveChart.SetElement (msoElementDataLabelCenter)
ActiveChart.SeriesCollection(2).Points(1).Select
ActiveChart.ChartArea.Select
ActiveChart.ChartArea.Select
ActiveChart.SeriesCollection(2).Points(1).Select
ActiveChart.PlotArea.Select
ActiveChart.SeriesCollection(2).Select
ActiveChart.SetElement (msoElementDataLabelCenter)
ActiveChart.SetElement (msoElementPrimaryValueAxisTitleHorizontal)
Selection.Caption = "hrs"
ActiveChart.Axes(xlValue).AxisTitle.Select
Selection.Left = 7
Selection.Top = 13.028
I have tried
Sheets("statistics").Range("A101:C106").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlColumnStacked
ActiveChart.SetSourceData Source:=Range("statistics!$A$101:$C$106")
ActiveChart.ChartArea.Select
Set ThisChart = ActiveChart
ActiveSheet.Shapes(ThisChart).Name = "waterfall"
but it is not working
Try the code below, it will loop through all existing ChartObjects in "statistics" worksheet, and if it finds a chartobject with a name of "Chart 9" it will rename it to "waterfall".
Note: you could use a similar approach to create the chart, without the need to use Select, ActiveSheet and ActiveChart.
Code
Option Explicit
Sub RenameExistingChart()
Dim ChtObj As ChartObject
For Each ChtObj In Worksheets("statistics").ChartObjects
If ChtObj.Name = "Chart 9" Then
ChtObj.Name = "waterfall"
End If
Next ChtObj
End Sub
Edit 1: create the chart with ChtObj:
Set ChtObj = Worksheets("statistics").ChartObjects.Add(Left:=100, Top:=100, _
Width:=100, Height:=100) ' <-- just default settings , modify later
With ChtObj
.Chart.ChartType = xlColumnStacked
.Chart.SetSourceData Source:=range("statistics!$A$101:$C$106")
.Name = "waterfall"
With .Chart.SeriesCollection(2).Format.Fill ' modify fill for series (2)
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent3
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Solid
End With
.Chart.SeriesCollection(1).ApplyDataLabels ' add data lables to series (1)
End With
You could use something like this:
Sub ChartStuff()
Dim cht As Shape
Range("A101:A106").Select
ActiveSheet.Shapes.AddChart.Select
Set cht = ActiveSheet.Shapes(1)
cht.Name = "waterfall"
End Sub
Hope this helps!
Dealing with charts in VBA is a little complicated.
When you use Addchart, Selection will be a ChartArea
A ChartArea is part of a Chart which is part of a ChartObject
The name of a chart you see is in fact the name of the ChartObject
You can do something like this:
Range("A101:A106").Select
ActiveSheet.Shapes.AddChart.Select
Dim ca As ChartArea, ch As Chart, co As ChartObject
Set ca = Selection
Set ch = ca.Parent
ch.ChartType = xl3DColumn
Set co = ch.Parent
co.Name = "waterfall"
Debug.Print ca.Name, ch.Name, co.Name
Create a function that you call from within the sub, that sends the name of the active chart, for example:
Function actchart(ActiveChart As String) As String
actchart = ActiveChart
End Function
And then from within your sub, you can replace, as an example, where you have:
ActiveSheet.Shapes("Chart 9").Name = "waterfall"
with
ActiveSheet.Shapes(actchart(ActiveChart.Parent.Name)).Name = "waterfall"
This worked for me with the same issue! Hope it helps.
I am trying to make my vba script below to add annotation notes to powerpoint slides. The idea is that the script can be used to add "to-be-checked notes" to slides. Hence, I've got it set up in a little add-in that displays a menu so adding the TBC, TBU, TBD notes are added.
The sub is showing errors from time to time and does not always fully do its job (i guess because of the part where I wrote in my code:
ActiveWindow.Selection.SlideRange.Shapes("Rectangle 4").Select
Can anyone assist me how do make the script bulletproof. A short explanation of the approach would be great. That way I can learn how do things right in the future.
Best,
eltiburon
This is what my entire script so far looks like:
Sub InsertShape_TBC()
ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 575.5, 9.12, 124.75, 34.12).Select
With ActiveWindow.Selection.ShapeRange
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.RGB = RGB(162, 30, 36)
.Fill.Transparency = 0#
.Line.Visible = msoFalse
End With
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
With ActiveWindow.Selection.TextRange
.Text = "[TBC]"
With .Font
.Name = "Arial"
.Size = 18
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppForeground
End With
End With
ActiveWindow.Selection.SlideRange.Shapes("Rectangle 4").Select
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
ActiveWindow.Selection.SlideRange.Shapes("Rectangle 4").Select
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=6).Select
ActiveWindow.Selection.TextRange.Font.Bold = msoTrue
ActiveWindow.Selection.TextRange.Font.Color.RGB = RGB(Red:=255, Green:=255, Blue:=255)
ActivePresentation.ExtraColors.Add RGB(Red:=255, Green:=255, Blue:=255)
ActiveWindow.Selection.Unselect
End Sub
This looks like the kind of code produced by the macro recorder in earlier versions of PPT.
First off, never select anything in code unless it's absolutely necessary to do so (and it seldom is). Use shape references instead (as you've seen in a couple of the other examples I posted in response to your other questions).
Because the recorded macro assumes that you're working with a shape called Rectangle 4, it will only work if you run it on a slide that has three rectangles already. So instead:
Dim oSh as Shape
Set oSh = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 575.5, 9.12, 124.75, 34.12)
' Notice that I removed the .Select from the end of your code.
' We don't want to select anything if we don't have to.
' Then
With oSh
With .TextFrame.TextRange
.Text = "[TBC]"
With .Font
.Name = "Arial"
.Size = 18
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppForeground
End With ' Font
End with ' TextRange
End With ' oSh, the shape itself