1

我正在尝试将文本添加到 PowerPoint 中的几个椭圆（已经创建和定位的形状）。这些值是从 Excel 中读取的。另外，我想更改 PowerPoint 中形状的颜色：如果值 >0，它应该是绿色，如果它是 <0，它应该是红色。我正在尝试这个，但遇到了错误。任何帮助将不胜感激。我最初是在做 Alt-H、S、L、P 并双击名称将它们更改为 Oval11、Oval12 等。

版本：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
4

1 回答 1

1

是的，包括组中的形状会导致错误。您可以取消组合形状或使用函数返回对所需形状的引用，即使它在组中：

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
于 2013-08-22T16:04:28.190 回答