CODEWITHSUNDEEP
excelvbapowerpointshapes
Siddhartha
Siddhartha

Reputation: 147

VBA: Excel Cell Values written to Ovals in Powerpoint

I am trying to add text to a few ovals (shapes which are already created and positioned) in PowerPoint. The values are read from Excel.Also, I would like to change the color of the shapes in PowerPoint: if value >0, it should be green and if it is <0, it should be red. I am trying this, but running into errors. Any help will be highly appreciated. I am initially doing Alt-H,S,L,P and double clicking on names to change them to Oval11, Oval12, etc.

Version: Excel2010, PowerPoint2010

 'Code starts
    Sub AutomateMIS()
        'Declare variables
        Dim oPPTApp As PowerPoint.Application
        Dim oPPTFile As PowerPoint.Presentation
        Dim oPPTShape As PowerPoint.Shape
        Dim oPPTSlide As PowerPoint.Slide
        Dim SlideNum As Integer

        'Instatntiate Powerpoint and make it visble
        Set oPPTApp = CreateObject("PowerPoint.Application")
        oPPTApp.Visible = msoTrue

        'Opening an existing presentation
        Set oPPTFile = oPPTApp.Presentations.Open(Filename:=ThisWorkbook.Path & "\" & "MIS.pptx")

       'Some Code before this
       SlideNum=1
       i=3
       'Update Ovals on next slide
            Set oPPTShape = oPPTFile.Slides(SlideNum + 1).Shapes("Oval11")
            oPPTShape.TextFrame.TextRange.Text = c.Offset(, 5).Value
            Set oPPTShape = oPPTFile.Slides(SlideNum + 1).Shapes("Oval12")
            oPPTShape.TextFrame.TextRange.Text = c.Offset(, 7).Value
            Set oPPTShape = oPPTFile.Slides(SlideNum + 1).Shapes("Oval" & (i + 1) & "3")
            oPPTShape.TextFrame.TextRange.Text = c.Offset(, 8).Value
            Set oPPTShape = oPPTFile.Slides(SlideNum + 1).Shapes("Oval" & (i + 1) & "4")
            oPPTShape.TextFrame.TextRange.Text = c.Offset(, 9).Value


    End Sub

Upvotes: 1

Views: 1483

Answers (1)

Steve Rindsberg
Steve Rindsberg

Reputation: 14809

Yes, including the shape in the group is causing the error. You can either ungroup the shapes or use a function to return a reference to the needed shape, even if it's in a group:

Function ShapeNamed(sName As String, oSlide As Slide) As Shape

    Dim oSh As Shape
    Dim x As Long

    For Each oSh In oSlide.Shapes
        If oSh.Name = sName Then
            Set ShapeNamed = oSh
            Exit Function
        End If
        If oSh.Type = msoGroup Then
            For x = 1 To oSh.GroupItems.Count
                If oSh.GroupItems(x).Name = sName Then
                    Set ShapeNamed = oSh.GroupItems(x)
                End If
            Next
        End If

    Next

End Function

Sub TestItOut()
    Dim oSh as Shape
    Set oSh = ShapeNamed("Oval 5", ActivePresentation.Slides(1))
    If not oSh is Nothing Then
      If ValueFromExcel < 0 then
        oSh.Fill.ForeColor.RGB = RGB(255,0,0)
      Else
        oSh.Fill.ForeColor.RGB = RGB(0,255,0)
      End if
    End If
End Sub

Upvotes: 1

Related Questions