Add a shape to a slide and format that - vba

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

Related

Powerpoint VBA - write function to create shape

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
```

Get chart name with VBA

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.

VBA: Formatting Multiple Selected Charts (Chart, Plot, Legend, etc.)

I am looking to format multiple selected charts on Excel 2010 using VBA. I want the code to work whether I choose one or multiple charts. The code below works when only one chart is selected but when multiple charts are selected, I get a "run-time error '91' Object variable or With Block variable not set". Any idea how to run the macro for number of selected charts?
Sub ChartFormat5_Click()
''Adjust chart area
ActiveChart.ChartArea.Select
'Size
Selection.Width = 631.9
Selection.Height = 290.1
'Border
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Weight = 1
.DashStyle = msoLineSolid
End With
'Font
With Selection.Format.TextFrame2.TextRange.Font
.Name = "Calibri"
.Size = 10
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
End With
''Adjust axis alignment and format
ActiveChart.Axes(xlCategory).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
End With
ActiveChart.Axes(xlCategory).TickLabelSpacing = 1
ActiveChart.Axes(xlCategory).TickLabels.Orientation = 45
ActiveChart.Axes(xlValue).Select
Selection.TickLabels.NumberFormat = "#,##0_);(#,##0)"
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
End With
ActiveChart.Axes(xlValue).AxisTitle.Select
Selection.Left = 1.5
Selection.Format.Line.Visible = msoFalse
''Adjust legend box
ActiveChart.Legend.Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 255)
.Transparency = 0
.Solid
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.5
.Transparency = 0
End With
Selection.Left = 124
Selection.Top = 67
''Adjust plot area size and format
ActiveChart.PlotArea.Select
'Borders
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Weight = 0.75
.DashStyle = msoLineSolid
End With
'Size
Selection.Width = ActiveChart.ChartArea.Width - 30.4
Selection.Height = ActiveChart.ChartArea.Height - 8.5
Selection.Top = 4
Selection.Left = 20
'Gridlines
ActiveChart.Axes(xlValue).MajorGridlines.Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.DashStyle = msoLineDash
End With
End Sub
This will process the active chart or all selected charts. The first routine determines what to process (active chart or selected charts) and the second processes each.
Sub FormatCharts()
Dim obj As Object
If Not ActiveChart Is Nothing Then
FormatOneChart ActiveChart
Else
For Each obj In Selection
If TypeName(obj) = "ChartObject" Then
FormatOneChart obj.Chart
End If
Next
End If
End Sub
Sub FormatOneChart(cht As Chart)
' do all your formatting here, based on cht not on ActiveChart
End Sub
Don't select parts of the chart, just fully reference them. Instead of
ActiveChart.ChartArea.Select
With Selection.Format.Line
use this
With cht.ChartArea.Format.Line
etc.
Just started answering questions on stackoverflow, so I hope this will help you out.
Since you selected multiple charts at once, you should scrap ActiveChart.ChartArea.Select
Just loop through each ChartObject in your current selection as follows:
Sub ChartFormat5_Click()
Dim cObject As ChartObject
For Each cObject In Selection
With cObject
'Do all your stuff here... E.g.
.Chart.PlotArea.Width = 631.9
End With
Next cObject
End Sub

VBA formatting strings

As of right now everything is red. I need everything after the colon to be black and not be Italic.
You just need to isolate the characters after the colon and set the colour as required:
EDIT: Forgot about the italic bit......
Sub test()
sCallOut = "ACTION: [Insert Callout Here]"
Set oShp = pptSld.Shapes.AddTextbox(msoTextOrientationHorizontal, 110, 100, 557.28, 94.32)
oShp.Line.Visible = msoFalse
oShp.TextFrame.TextRange.Text = sCallOut
oShp.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
With oShp.TextFrame.TextRange.Font
.Name = "Corbel"
.Italic = msoTrue
.Size = 20
.Color.RGB = RGB(216, 3, 33)
.Bold = msoTrue
End With
With oShp.TextFrame.TextRange
With .Characters(InStr(.Characters, ":") + 1, .Length).Font
.Color.RGB = RGB(0, 0, 0)
.Italic = msoFalse
End With
End With
Set oShp = Nothing
End Sub
You can change this line to make the text black:
.Color.RGB = RGB(216, 3, 33)
And this line to remove italics:
.Italic = msoFasle
EDIT:
If you have the cell location, you can do this to the string later on:
With Cells(1, 1).Characters(9, 21).Font
.Color = vbBlack
.Italic = False
.Name = "Corbel"
.Size = 20
This shows how to use Characters
EDIT:
To change part of the text for a text box, you can declare two variables containing strings formatted differently and append them to the textbox.
It will follow the form:
MyTextBox.Value = MyStringVariable
or in your case:
MyTextBox.Value = MyStringVariable1 & MyStringVariable2
The macro recorder found the following:
Sub test()
ActiveSheet.Shapes.Range(Array("txtbox1")).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
"Choisir: wefhweufhwef 344tr saefaefa" 'Entering some text'
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 5).Font 'Selecting some font and changing some settings
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(0, 0, 255)
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
End Sub
I haven't managed to do it without selecting the textbox first (?? maybe someone can help, usually it isn't hard). You can enter your text with a string in which you figure out the position of the colon using
dim MyString as string
dim intColon as integer
Mystring = "cwsvws:wifvwhivw"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = MyString
intColon = instr(MyString, ":")
And use this as the character count to plug in the macro recorder's code. Then you can format different blocks of text how you want.
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(intColon, 5).Font
.Fill.ForeColor.RGB = RGB(0, 0, 255)
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
Hope this helps.

wdWrapBehind in word (2003) vba

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