Как я могу изменить цвет шрифта для всех текстовых полей с одинаковым именем объекта во всей книге на красный?

Question

Я хочу изменить цвет всех текстовых полей с именем «Placeholder1» на красный.

Я использую следующую функцию для копирования и вставки объекта из ppt в excel. Я также использую, чтобы изменить цвет шрифта на красный, но он не работает на некоторых текстовых полях. Большинство листов имеют 1 текстовое поле. За исключением одного листа около 4. На этом листе только 1 текстовое поле меняет цвет. Как я могу сделать так, чтобы все цвета шрифта были установлены на красный?

 Function paste_from_slide(slideIndex As Integer, _
    targetWsName As String, destinationRng As String, Optional shapeName As String = "Content Placeholder 1")

    Dim pptShape As PowerPoint.Shape
    Dim pptSlide As PowerPoint.Slide
    Dim exlShape As Excel.Shape
    Dim s As Shape

    Dim Ws As Excel.Worksheet
    Dim Rng As Excel.Range

    Set Ws = Excel.ThisWorkbook.Worksheets(targetWsName)
    Set Rng = Ws.Range(destinationRng)

    Set pptSlide = Ppt.ActivePresentation.Slides(slideIndex)
    Set pptShape = pptSlide.Shapes(shapeName)
        pptShape.Copy
         ActiveSheet.Paste Destination:=Ws.Range(destinationRng)

    Set s = Ws.Shapes("Content Placeholder 1")

s.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)


End Function

Answer 1

• Имена фигур не являются надежным индикатором фактического типа фигуры.
• Именование заполнителей с одинаковыми именами может привести к случайному повороту содержимого между ними при переключении макетов, поэтому пересмотренный код не полагается на имя.
• Попытка заполнить текст, если есть Если текст отсутствует, возникнет ошибка.
• Нет причин делать это функцией, поскольку она ничего не возвращает.

Пожалуйста, попробуйте этот код:

Sub paste_from_slide(slideIndex As Integer, _
    targetWsName As String, destinationRng As String, Optional shapeName As String)

    Dim pptShape As PowerPoint.Shape, oShape As Shape
    Dim pptSlide As PowerPoint.Slide
    Dim exlShape As Excel.Shape
    Dim s As Shape
    Dim Ws As Excel.Worksheet
    Dim Rng As Excel.Range

    Set Ws = Excel.ThisWorkbook.Worksheets(targetWsName)
    Set Rng = Ws.Range(destinationRng)
    Set pptSlide = Ppt.ActivePresentation.Slides(slideIndex)

    For Each pptShape In pptSlide
        If pptShape.Type = msoPlaceholder Then  'Check shape is a placeholder, as the name is an unreliable indicator.
            If pptShape.PlaceholderFormat.Type = ppPlaceholderObject Then   'Check that the placeholder is the right type.
                'If you still want to check the name, add an If/Then here to do that.
                Set oShape = pptShape
                If oShape.TextFrame2.HasText Then   'Trying to fill the text of a placeholder that doesn't have any will raise an error
                    oShape.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
                End If
                oShape.Copy
                ActiveSheet.Paste Destination:=Ws.Range(destinationRng)
            End If
        End If
    Next pptShape
End Sub