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
Related
I want to take all the articles in Word document and transform them into PowerPoint Presentation.
1 article = 1 slide (if the text does not fit shrink it, else create a new slide).
I managed to recognize each part of the article by its Style in Word. I get text by its style and insert it into a slide and so forth. I retrieve text by paragraphs (Selection.StartOf and EndOf didn't work).
I didn't find a way to avoid overlaying one text over the other.
Maybe I can get what I need by the coordinates of the textframes?
What I have got so far:
For Each StyleInWord In ActiveDocument.Paragraphs
If StyleInWord.Style = "NAME_OF_THE_ARTICLE" Then
wordText0 = StyleInWord.Range
Set pptLayout = pptPres.SlideMaster.CustomLayouts.Add(ppLayoutBlank)
Set pptSlide = pptPres.Slides.AddSlide(1, pptLayout)
If pptPres.Slides(1).Shapes(1).HasTextFrame Then
pptPres.Slides(1).Shapes(1).Delete
End If
With pptPres.PageSetup
.SlideSize = ppSlideSizeCustom
.SlideHeight = CentimetersToPoints(21.008)
.SlideWidth = CentimetersToPoints(28.011)
End With
Set mySlide = pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(1.31), CentimetersToPoints(3.73), CentimetersToPoints(24.34), CentimetersToPoints(12.57))
With mySlide.TextFrame.TextRange
.Text = wordText0
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
End If
If StyleInWord.Style = "DESCRIPTION_OF_THE_ARTICLE" Then
wordText1 = StyleInWord.Range
Set mySlide = pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(1.31), CentimetersToPoints(5.73), CentimetersToPoints(24.34), CentimetersToPoints(12.57))
With mySlide.TextFrame
With .TextRange
.Text = wordText1
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
End With
End If
If StyleInWord.Style = "MAIN_TEXT_OF_THE_ARTICLE" Then
Set mySlide = pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(1.31), CentimetersToPoints(7.73), CentimetersToPoints(24.34), CentimetersToPoints(12.57))
wordText2 = StyleInWord.Range
With mySlide.TextFrame
With .TextRange
.Text = wordText2
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
End With
End If
Next StyleInWord
'Here i change the order, so the first slide i create will stay the first by the end of the forEachLoop
i = 1
For i = 1 To pptPres.Slides.Count
pptPres.Slides(i).MoveTo 1
Next i
Each time you add a textbox you set the top position to simply be 2cm lower than the previous one. This takes no account of the height of the previous text box.
There is a very simple solution to this. A text box has properties for both top and height, so just store those in variables. That way you can add each new text box directly below the previous one.
Your code also needs some improvement as some of the presentation setup you are doing should be outside the loop. You should also rename mySlide as pptTextBox so that the variable has a logical name that is consistent with the others.
Set pptLayout = pptPres.SlideMaster.CustomLayouts.Add(ppLayoutBlank) doesn't do what you think it does and is unnecessary. The presentation will already contain a blank layout, helpfully named "Blank", so all you need to do is set a pointer to it, again outside the loop.
'do presentation setup outside the loop
With pptPres.PageSetup
.SlideSize = ppSlideSizeCustom
.SlideHeight = CentimetersToPoints(21.008)
.SlideWidth = CentimetersToPoints(28.011)
End With
'a presentation will already include a blank layout so there is no need to create one
For Each pptLayout In pptPres.SlideMaster.CustomLayouts
If pptLayout.Name = "Blank" Then Exit For
'pptLayout now points to the Blank layout
Next
For Each StyleInWord In ActiveDocument.Paragraphs
If StyleInWord.Style = "NAME_OF_THE_ARTICLE" Then
wordText0 = StyleInWord.Range
Set pptSlide = pptPres.Slides.AddSlide(1, pptLayout)
If pptPres.Slides(1).Shapes(1).HasTextFrame Then
pptPres.Slides(1).Shapes(1).Delete
End If
Set pptTextBox = _
pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
CentimetersToPoints(1.31), CentimetersToPoints(3.73), _
CentimetersToPoints(24.34), CentimetersToPoints(12.57))
With pptTextBox
With .TextFrame.TextRange
.Text = wordText0
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
textBoxTop = .Top
textBoxHeight = .Height
End With
End If
If StyleInWord.Style = "DESCRIPTION_OF_THE_ARTICLE" Then
wordText1 = StyleInWord.Range
Set pptTextBox = _
pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
CentimetersToPoints(1.31), textBoxTop + textBoxHeight, _
CentimetersToPoints(24.34), CentimetersToPoints(12.57))
With pptTextBox
With .TextFrame.TextRange
.Text = wordText1
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
textBoxHeight = textBoxHeight + .Height
End With
End If
If StyleInWord.Style = "MAIN_TEXT_OF_THE_ARTICLE" Then
Set pptTextBox = _
pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
CentimetersToPoints(1.31), textBoxTop + textBoxHeight, _
CentimetersToPoints(24.34), CentimetersToPoints(12.57))
wordText2 = StyleInWord.Range
With pptTextBox
With .TextFrame.TextRange
.Text = wordText2
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
textBoxHeight = textBoxHeight + .Height
End With
End If
Next StyleInWord
'Here i change the order, so the first slide i create will stay the first by the end of the forEachLoop
i = 1
For i = 1 To pptPres.Slides.Count
pptPres.Slides(i).MoveTo 1
Next i
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
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
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
Powerpoint 2010
I am trying to select on each new shape in the loop. But not all shapes in loop are selected. Always only the last shape is selected. What is wrong?
Thank you
Private Sub AddShapeRectangleOnSelectedText()
Dim oText As TextRange
Dim linesCount As Integer
Dim myDocument As Slide
Dim i As Integer
Dim s As Shape
' Get an object reference to the selected text range.
Set oText = ActiveWindow.Selection.TextRange
Set myDocument = ActiveWindow.View.Slide
linesCount = oText.Lines.Count
For i = 1 To linesCount
Set s = myDocument.Shapes.AddShape(msoShapeRectangle, _
oText.Lines(i).BoundLeft, oText.Lines(i).BoundTop, oText.Lines(i).BoundWidth, oText.Lines(i).BoundHeight)
With s
.Select
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.RGB = RGB(255, 255, 153)
.Fill.Transparency = 0.7
.Line.Visible = msoFalse
.Line.Transparency = 0#
End With
Next
End Sub
Select has an optional parameter to indicate whether the selection should replace the previous selection or not...
you can modify your code like this
.Select IIf(i = 1, True, False)