Powerpoint - VBA - Slide status - vba

I hope you are doing well.
I am a little stuck on a macro scripting, I would like to perform the following
Once the macro is launch ; create a form rectangle with attributes (see below)
If a rectangle already exist within the active slide the delete it.
Here is the little macro code written to insert the shape
Sub TBU()
Dim oSh As Shape
Set oSh = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 902, 5, 47, 27)
With oSh
With .TextFrame.TextRange
.Text = "[TBU]"
With .Font
.name = "Arial"
.Size = 12
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color = RGB(255, 0, 0)
End With
End With
With oSh
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 0)
.Fill.Solid
End With
End With
End Sub
I tried to delete the shape within the active slide only if a rectangle with the same attributes already existed but got stuck on that.
Does anyone has an idea?
Kind regards,
Naxos

I think the best way to find any shapes that you want to delete is to iterate over all the shapes in the current slide, and call a function that checks if the shape given matches your criteria.
It would look something like the code below. Basically, any one condition not matching is sufficient to say that the shape shouldn't be deleted. Therefore the function starts off by assuming that the shape should be deleted until it finds any condition that indicates otherwise, at which point it changes the return value to false and ceases checking for the given shape.
Dim i as Long
Dim sh as Shape
For i = ActiveWindow.View.Slide.Shapes.Count to 1 Step -1
Set sh = ActiveWindow.View.Slide.Shapes(I)
If ShouldBeDeleted(sh) Then
sh.Delete
End If
Next
'...
Function ShouldBeDeleted(sh as Shape) as Boolean
ShouldBeDeleted = True
'Repeat this IF structure for each criteria.
If sh.Fill.Visible <> msoTrue Then
ShouldBeDeleted = False
Exit Function
End If
If Not sh.HasTextFrame Then
ShouldBeDeleted = False
Exit Function
End If
'... keep repeating these if structures.
End Function

Related

Why do I get the specified value is out of range when accessing the shape object?

I wrote this function to loop through powerpoint slides in a vba macro. I wanted it to then loop through the shapes on each slide and set the text to user defined defaults.
I got this working and now for some reason after tidying up it stopped working. I get Run-time-error '-2147024809 (80070057) The specified value is out of range.
When I debug it works up to a certain slide. In my case it's a test slide with 5 objects of different types with text in. There is a group.
Despite doing some study and training this one has me stumped. Would really appreciate some help. I'm sure it's a simple solution but I can't see what I'm doing wrong.
Sub FontDefaultAllSlidesBody()
'Sets the text for all shapes on all slides in active presentation
'Set variables for functions
Dim oSl As Slide
Dim oSls As Slides
Set oSls = ActivePresentation.Slides
'Set our default font settings
For Each oSl In oSls
For i = 1 To oSl.Shapes.Count
With oSl.Shapes(i).TextFrame.TextRange.Font
.Size = 16
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Color = msoThemeColorAccent1
.Name = "+mn-lt"
End With
Next i
Next oSl
End Sub
This will probably be enough to solve the problem. It tests each shape to see if it can contain text and if so, if it does contain text and only then does it try to modify the text.
I've also changed the loop a bit to use a Shape object; cuts out a lot of typing and (I think) makes it clearer what you're dealing with.
Sub FontDefaultAllSlidesBody()
'Sets the text for all shapes on all slides in active presentation
'Set variables for functions
Dim oSl As Slide
Dim oSls As Slides
' This will make it easier to read:
Dim oSh as Shape
Set oSls = ActivePresentation.Slides
'Set our default font settings
For Each oSl In oSls
For Each oSh in oSl.Shapes
' Add this to keep it from touching shapes that
' can't contain text
If oSh.HasTextFrame Then
' And skip shapes that have no text
If oSh.TextFrame.HasText Then
With oSh.TextFrame.TextRange.Font
.Size = 16
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Color = msoThemeColorAccent1
.Name = "+mn-lt"
End With
End If ' HasText
End If ' HasTextFrame
Next ' Shape
Next oSl
End Sub

find the next shape with a special tag

For internal communication purposes in a group of people I have created a macro adding comment fields to a slide - not those of PPT itself.
Dim shp As Shape
Dim sld As Slide
'Comment field
On Error GoTo ErrMsg
If ActiveWindow.Selection.SlideRange.Count <> 1 Then
MsgBox "This function cannot be used for several slides at the same time"
Exit Sub
Else
Set sld = Application.ActiveWindow.View.Slide
Set shp = sld.Shapes.AddShape(Type:=msoShapeRectangle, Left:=0, Top:=104.88182, Width:=198.42507, Height:=28.913368)
shp.Fill.Visible = msoTrue
shp.Fill.Transparency = 0
shp.Fill.ForeColor.RGB = RGB(211, 61, 95)
shp.Line.Visible = msoTrue
shp.Line.ForeColor.RGB = RGB(255, 255, 255)
shp.Line.Weight = 0.75
shp.Tags.Add "COMMENT", "YES"
shp.Select
shp.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
shp.TextFrame.TextRange.Characters.Text = "Comment: "
shp.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
shp.TextFrame.VerticalAnchor = msoAnchorTop
shp.TextFrame.TextRange.Font.Size = 12
shp.TextFrame.TextRange.Font.Name = "Arial"
shp.TextFrame.TextRange.Font.Bold = msoTrue
shp.TextFrame.TextRange.Font.Italic = msoFalse
shp.TextFrame.TextRange.Font.Underline = msoFalse
shp.TextFrame.Orientation = msoTextOrientationHorizontal
shp.TextFrame.MarginBottom = 7.0866097
shp.TextFrame.MarginLeft = 7.0866097
shp.TextFrame.MarginRight = 7.0866097
shp.TextFrame.MarginTop = 7.0866097
shp.TextFrame.WordWrap = msoTrue
shp.TextFrame.AutoSize = ppAutoSizeShapeToFitText
shp.TextFrame.TextRange.Select
End If
Exit Sub
ErrMsg:
MsgBox "Please select a slide"
End Sub
Works well.
I have tagged them, because I want it to be easy to delete all of them at once, e.g., in case you find comments 5 minutes before you have to present. Here's my way to delete them:
Sub CommDel()
Dim sld As Slide
Dim L As Long
If MsgBox("Do you want to delete ALL comments from the entire presentation?", vbYesNo) <> vbYes Then Exit Sub
On Error Resume Next
For Each sld In ActivePresentation.Slides
For L = sld.Shapes.Count To 1 Step -1
If sld.Shapes(L).Tags("COMMENT") = "YES" Then sld.Shapes(L).Delete
Next L
Next sld
End Sub
Works fine, too.
Third step I would like to do, is creating a third macro, called "find next comment". On every click it jumps to the next shape tagged with the tag "COMMENT", no matter if that shape is on the same slide or the next or somewhere else in the presentation. Just the next one, where ever it is. And now I'm completely lost. I am able to do something to all tagged shapes on one slide or inthe entire presentation - as you can see in the function to delete. But what I'm looking for is not selecting all shapes at the same time. In another try I was able to find the first one - but after clicking the macro again nothing seemed to happen, because the macro started searching at the same point and selected the same shape again and again, never jumping to the next one, except I deleted the first one.
Would be great to read your ideas. Thank you in advance. But be careful, I'm far from being a good programmer. ;-)
This starts at the current slide and works toward the end, dropping out of the Sub as soon as the first comment is found:
Sub FindNextComment()
Dim oSlide As Slide
Dim oShape As Shape
Set oSlide = ActiveWindow.View.Slide
For Each oShape In oSlide.Shapes
If oShape.Tags.Count > 0 Then
For y = 1 To oShape.Tags.Count
If oShape.Tags.Name(y) = "COMMENT" Then
oShape.Select
Exit Sub
End If
Next y
End If
Next oShape
For x = oSlide.SlideIndex + 1 To ActivePresentation.Slides.Count
For Each oShape In ActivePresentation.Slides(x).Shapes
If oShape.Tags.Count > 0 Then
For y = 1 To oShape.Tags.Count
If oShape.Tags.Name(y) = "COMMENT" Then
ActivePresentation.Slides(x).Select
oShape.Select
Exit Sub
End If
Next y
End If
Next oShape
Next x
End Sub
Bonus VBA Tip: You can make your code run a little faster by using With statements:
With shp.TextFrame
.MarginBottom = 7.0866097
.MarginLeft = 7.0866097
.MarginRight = 7.0866097
.MarginTop = 7.0866097
.WordWrap = msoTrue
.AutoSize = ppAutoSizeShapeToFitText
.Orientation = msoTextOrientationHorizontal
.VerticalAnchor = msoAnchorTop
With .TextRange
.Characters.Text = "Comment: "
.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
With .Font
.Size = 12
.Name = "Arial"
.Bold = msoTrue
.Italic = msoFalse
.Underline = msoFalse
End With
End With
End With

microsoft excel - how to fit image inside shape?

i have typed some image locations in some cells and hyperlinked them. when i click this cells, a macro will be executed and fills a rectangle shape with pictures specified in those cells. this is the macro:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Row = ActiveCell.Row
col = ActiveCell.Column
ActiveSheet.Shapes.Range(Array("Rectangle 38")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture ActiveSheet.Cells(Row, col).Value
End With
End Sub
it works but the picture is stretched. i want the picture to be fitted inside my shape. in excel , as you might know , after filling a shape with picture,there is a fit button under crop option. when you click it, it fits the image inside the picture box and maintains the size of shape. i want to do the exact thing only in VBA.
Use the shape properties of .PictureWidth , .PictureHeight , .PictureOffsetX = .PictureOffsetY.
Code example:
Option Explicit
Public Sub AddPicAndAdjust()
Dim shp As ShapeRange
Set shp = ActiveSheet.Shapes.Range(Array("Rectangle 1"))
With shp.Fill
.Visible = msoTrue
.UserPicture "C:\Users\User\Pictures\MyNicePic.png" '<== Add pic
.TextureTile = msoFalse
.RotateWithObject = msoTrue
End With
'Positioning within fill
With shp.PictureFormat.Crop
.PictureWidth = 231
.PictureHeight = 134
.PictureOffsetX = 50
.PictureOffsetY = 28
End With
With shp
.LockAspectRatio = msoFalse
.IncrementLeft 2
End With
End Sub

PowerPoint VBA Recognizing Shapes in a Grouping

I am trying to create a simple PowerPoint file to capture a series of milestones for a project portfolio. I have created the following Macro to create the milestone visual and group the shapes. However, I am looking to create another macro for updating/statusing the milestone. Specifically, I want the user to select the group and then run a macro to that will allow the user to update the date and move the shapes accordingly or, if the task is complete, fill in the shape.
I struggle with the initiation of the update macro to identify the shapes and its' content to complete the calculation. For example, I don't know how to read in the date in to move the milestone left/right based on the new date. Any help is appreciated!
Code:
Private Sub EnterTask_Click()
Dim Sld As Slide
Dim shapeMile As Shape
Dim shapeTask As Shape
Dim shapeECD As Shape
Dim dateECD As String
Dim taskText As String
Dim StatusBox As Shape
dateECD = "6/12/18"
taskText = "Task #1"
Set Sld = Application.ActiveWindow.View.Slide
With Sld
'Create shape with Specified Dimensions and Slide Position
Set shapeMile = Sld.Shapes.AddShape(Type:=msoShapeIsoscelesTriangle, _
Left:=25, Top:=150, Width:=15, Height:=15)
With shapeMile
.Rotation = 180
.Tags.Add "Milestone", "Bug"
.Line.Visible = msoTrue
.Fill.Visible = msoFalse
.Shadow.Visible = msoFalse
End With
Set shapeECD = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=8, Top:=165, Width:=50, Height:=30)
With shapeECD
.Tags.Add "Milestone", "ECD"
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
.Shadow.Visible = msoFalse
.TextFrame.TextRange.Characters.Text = dateECD
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
.TextFrame.VerticalAnchor = msoAnchorTop
.TextFrame.HorizontalAnchor = msoAnchorCenter
.TextFrame.TextRange.Font.Size = 8
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Italic = msoFalse
.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
End With
Set shapeTask = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=8, Top:=135, Width:=50, Height:=30)
With shapeTask
.Tags.Add "Milestone", "Task"
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
.Shadow.Visible = msoFalse
.TextFrame.TextRange.Characters.Text = taskText
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
.TextFrame.VerticalAnchor = msoAnchorTop
.TextFrame.HorizontalAnchor = msoAnchorCenter
.TextFrame.TextRange.Font.Size = 8
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Italic = msoFalse
.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
End With
.Shapes.Range(Array(shapeMile.Name, shapeECD.Name, shapeTask.Name)).Group
End With
End Sub

Find graph with data and change color of bars based on data in PowerPoint

I want to create a program that will:
cycle through all my slides and find slides that contain Chart(s), these charts are not linked to any worksheet.
Chart must contain data and will be of ChartType = xlColumnClustered or ChartType(51) Like in the bellow picture.
If it has data then look at the numbers and change the colors of each bar according to the graph below (>=6.0 then Red, <=8.0 then Blue, 6.0<= x >=8.0 then Purple)
I have tried searching through every Expression in the Locals window of the debugger to see if I could find any difference between a graph with data and a graph that has no data. I found nothing. I'm not sure how I would be able to differentiate between a slide with data and one without.
I also don't know how I would be able to access the data in the Chart to apply the colors.
Any help would be appreciated in how to handle this.
Thank you!
i recorded a macro in excel of changing bar colors and tweaked it
there actually is a spreadsheet in powerpoint that feeds data to each chart in powerpoint
Application.ActivePresentation.Slides(1).Shapes(1).Chart.ChartData.Workbook.activesheet
you will have to read data from the worksheet to decide the colors for the bars, i think
here is the color changer
Option Explicit
Sub Macro1()
' recorded in excel and modified
Dim chrt As Chart
' Set chrt = ActiveSheet.ChartObjects("Chart 1").Chart ' excel object
Set chrt = Application.ActivePresentation.Slides(1).Shapes(1).Chart
chrt.ClearToMatchStyle
chrt.ChartStyle = 203
chrt.ChartStyle = 340
chrt.ChartStyle = 333
chrt.ChartStyle = 399
chrt.ChartType = xlColumnClustered
Dim fsc As FullSeriesCollection
Set fsc = chrt.FullSeriesCollection
With fsc(1).Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 192, 0)
.Transparency = 0.5
.Solid
End With
With fsc(1).Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
With fsc(2).Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.25
.Transparency = 0
.Solid
End With
With fsc(3).Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(146, 208, 80)
.Transparency = 0
.Solid
End With
With fsc(3).Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
With fsc(1).Points(1).Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0.6299999952
.Solid
End With
With fsc(1).Points(1).Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0.0500000119
.Weight = 5
.Style = msoLineThickBetweenThin
End With
End Sub
This post helped me figure out what I needed to do, coupled with some of the logic posted here by #jsotola. This is the PowerPoint version of those two and does exactly what was needed in the original question.
Option Explicit
Public Sub colorGraph()
Dim sld As Slide
Dim shpe As Shape
Dim pres As Object
Dim nPoint As Long
Dim iPoint As Long
Dim c As Chart
Dim s As Series
Set pres = ActivePresentation
For Each sld In pres.Slides
For Each shpe In sld.Shapes
Set s = shpe.Chart.SeriesCollection(1)
If Not shpe.HasChart Then GoTo nxtShpe
If Not shpe.Chart.ChartType = xlColumnClustered Then GoTo nxtShpe
If s.DataLabels.NumberFormat = "0%" Or s.DataLabels.NumberFormat = "0.0%" Or s.DataLabels.NumberFormat = "0.00%" Then GoTo nxtShpe
nPoint = s.Points.Count
For iPoint = 1 To nPoint
If s.Values(iPoint) >= 8 Then
s.Points(iPoint).Interior.Color = RGB(0, 255, 0)
ElseIf s.Values(iPoint) < 8 And s.Values(iPoint) >= 2 Then
s.Points(iPoint).Interior.Color = RGB(255, 0, 0)
ElseIf s.Values(iPoint) < 2 And s.Values(iPoint) > 0 Then
s.Points(iPoint).Interior.Color = RGB(0, 0, 255)
End If
Next iPoint
nxtShpe:
Next shpe
Next sld
End Sub