使用 VBA 在 PowerPoint 中设置标题

Set Title in PowerPoint using VBA

提问by rjara

i'm new at macros and i'm trying to export some data from Excel to a PowerPoint Presentation. I need to put some cells from Excel as Titles in PowerPoint. Here is my code:

我是宏的新手，我正在尝试将一些数据从 Excel 导出到 PowerPoint 演示文稿。我需要将 Excel 中的一些单元格作为 PowerPoint 中的标题。这是我的代码：

    Sub CrearPresentacion2()

'Iniciar las variables
Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim myShapeRange As PowerPoint.ShapeRange

'Pedir al usuario un rango de celdas
Set rng = Application.InputBox("Seleccione el Rango para hacer Presentación", Title:="Seleccionar Rango", Type:=8)
On Error Resume Next

'Hacer PowerPoint visible
PowerPointApp.Visible = True
PowerPointApp.Activate

'Crear Nueva Presentacion
Set myPresentation = PowerPointApp.Presentations.Add

'Ciclo para copiar cada celda en una diapositiva
For Each Cell In rng.Cells
    Cell.Select
    Selection.Copy
    Dim ppSlide2 As PowerPoint.Slide
    Dim x As Integer
    x = myPresentation.Slides.Count + 1
    If x = 1 Then
        Set ppSlide2 = myPresentation.Slides.Add(Index:=x, Layout:=ppLayoutBlank)
        PowerPointApp.ActivePresentation.Slides(x).Select
        PowerPointApp.ActiveWindow.Selection.SlideRange.Select
        Set myShapeRange = ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText)
        Dim Header1 As String
        Header1 = "Example"
        Set myTitle = ppSlide2.Shapes.Title
        myTitle.TextFrame.TextRange.Characters.Text = Header1
    ElseIf x = 2 Then
        Set ppSlide2 = myPresentation.Slides.Add(Index:=x, Layout:=ppLayoutBlank)
        PowerPointApp.ActivePresentation.Slides(x).Select
        PowerPointApp.ActiveWindow.Selection.SlideRange.Select
        Set myShapeRange = ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText)
    Else
        Set ppSlide2 = myPresentation.Slides.Add(Index:=x, Layout:=ppLayoutText)
        PowerPointApp.ActivePresentation.Slides(x).Select
        PowerPointApp.ActiveWindow.Selection.SlideRange.Select
        Set myShapeRange = ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText)
    End If
Next Cell

CutCopyMode = False

When the counter is Equal to 1, I need to insert an "Example" title, but it says that "myTitle" object doesn't exist. In the second case, I need to put the cell as a Title, but I don't know how to use the function

当计数器等于 1 时，我需要插入一个“示例”标题，但它表示“myTitle”对象不存在。在第二种情况下，我需要将单元格作为标题，但我不知道如何使用该功能

ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText)

ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText)

Thanks for your help.

谢谢你的帮助。

回答by David Zemens

For the first problem, you are using Layout:=ppLayoutBlankwhich does nothave a Titleshape. You should use a layout which contains a Title shape.

对于第一个问题，你使用Layout:=ppLayoutBlank它并没有有一个Title形状。您应该使用包含标题形状的布局。

I will use ppLayoutTitleOnlybut you could use any layout which contains a title shape.

我会使用，ppLayoutTitleOnly但您可以使用任何包含标题形状的布局。

For the second case, let's store the value of Cellas a string variable, and use that to write to the slide's title shape. There is no need to use Copymethod. I'm also going to recommend moving your declarations to the top of your code -- VBA doesn't process DIM statements conditionally, so there's no good reason to put them inside your loop, and it only makes them harder to find later if you need to modify something.

对于第二种情况，让我们将 的值存储Cell为字符串变量，并使用它写入幻灯片的标题形状。不需要使用Copy方法。我还建议将您的声明移到代码的顶部——VBA 不会有条件地处理 DIM 语句，因此没有充分的理由将它们放在您的循环中，并且只会使您以后更难找到它们需要修改一些东西。

Notethis code is incomplete, and as such has not been tested.

请注意，此代码不完整，因此尚未经过测试。

Dim titleText As String
Dim ppSlide2 As PowerPoint.Slide
Dim x As Integer
Dim Header1 As String

PowerPointApp.Visible = True
PowerPointApp.Activate

'Crear Nueva Presentacion
Set myPresentation = PowerPointApp.Presentations.Add


'Ciclo para copiar cada celda en una diapositiva
For Each Cell In rng.Cells
    titleText = Cell.Value

    x = myPresentation.Slides.Count + 1
    If x = 1 Then
        Set ppSlide2 = myPresentation.Slides.Add(Index:=x, Layout:=ppLayoutTitleOnly)
        PowerPointApp.ActivePresentation.Slides(x).Select
        PowerPointApp.ActiveWindow.Selection.SlideRange.Select
        Set myShapeRange = ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText)
        Header1 = "Example"
        Set myTitle = ppSlide2.Shapes.Title
        myTitle.TextFrame.TextRange.Characters.Text = Header1
    ElseIf x = 2 Then
        Set ppSlide2 = myPresentation.Slides.Add(Index:=x, Layout:=ppLayoutTitleOnly)
        PowerPointApp.ActivePresentation.Slides(x).Select
        PowerPointApp.ActiveWindow.Selection.SlideRange.Select
        ' not sure what this next line does so I omit it
        'Set myShapeRange = ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText)
        Set myTitle = ppSlide2.Shapes.Title
        '## Insert the titleText from Cell variable in this slide's Title shape:
        myTitle.TextFrame.TextRange.Characters.Text = titleText
    Else
        Set ppSlide2 = myPresentation.Slides.Add(Index:=x, Layout:=ppLayoutText)
        PowerPointApp.ActivePresentation.Slides(x).Select
        PowerPointApp.ActiveWindow.Selection.SlideRange.Select
        Set myShapeRange = ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText)
    End If
Next Cell

CutCopyMode = False