vba - 将文本范围从 1 个电源点传输到另一个电源点以更改模板

Question

我对 Powerpoint VBA 非常陌生，想知道是否有一种简单的方法可以按特定顺序将一个文本范围从 PowerPoint A 传输到位于 Powerpoint B 中的另一个文本范围。

页面a1 = b1

页面a2 = b2

页面a3 = b3

模板正在更改，我需要调整 100 张幻灯片的 5 个幻灯片，因此我认为使用此解决方案会更容易。

预先感谢您的帮助。

精度:我不想复制并粘贴文本范围，而是复制范围内的文本以将其放入新范围内。请在下面找到我已有的代码，但它没有将其粘贴到我的新范围内。

Sub copier_texte()  'je veux copier le contenu de la forme, et non pas la forme en entier

Dim nb_slide As Integer
nb_slide = ActivePresentation.Slides.Count

With ActivePresentation
.Slides(1).Shapes(2).TextFrame.TextRange.Copy 'je sélectionne uniquement le contenu de la forme
For i = 2 To .Slides.Count
        .Slides(i).Select
        ActiveWindow.View.Paste
Next i
End With

End Sub 

Answer 1

简短回答:

Is there're a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B?

我认为没有捷径可以做到这一点，但让我们先尝试一下!

长答案:

注意:这个解决方案不是基于您想要的行为(因为我不清楚并且有越来越多的“假设”案例)，而是基于类似的问题，所以我认为它是合法的。不管怎样，这是一个很好的基础。

输入:

我不知道您的演示文稿到底是什么样子，因此我制作了一个引用演示文稿(演示文稿 A)和一个“损坏的”演示文稿(演示文稿 B)。让我们来看看它们:

• 演示文稿 A(5 张幻灯片:1 张带有 2 个三角形的“标题幻灯片”、3 张“标题和内容”幻灯片、1 张“章节标题”幻灯片):

• 演示文稿 B(5 张幻灯片:1 张缺少三角形的“标题幻灯片”、3 张带有空/无形状(占位符)的“标题和内容”幻灯片、1 张“空白”幻灯片 (布局错误)):

• 两个演示文稿都位于同一文件夹中:

  

期望的行为:

某种同步，如果我们错过了某个形状，则创建一个形状并将所需的文本放入其中，如果有的话，仅放置所需的文本(基于演示文稿 A 的形状)。逻辑上有一些“假设”情况:

• “如果”每个演示文稿中的幻灯片数量不相等怎么办？那么按什么顺序比较幻灯片呢？ (在我们的例子中，数字是相等的，因此在代码中我们删除该部分并逐对比较幻灯片)。
• “如果”比较的幻灯片具有不同的布局怎么办？ (在我们的例子中，空白布局有所不同，因此我们可以轻松处理它，但一般我们应该做什么？)
• ...以及此解决方案中未考虑的许多其他情况

逻辑:

逻辑简单明了。我们例程的入口点位于演示文稿 A 中，因为它是我们的引用文件。从那时起，我们获取对演示文稿 B 的引用(打开它时)，并在两个循环中开始迭代(通过每对幻灯片和引用形状)。 如果我们发现引用形状“损坏”(或没有损坏，则不会检查该形状) - 我们会在其中放置文本和一些选项，否则创建一个新的形状(或占位符)。

Option Explicit

Sub Synch()
    'define presentations
    Dim ReferencePresentation As Presentation
    Dim TargetPresentation As Presentation

    'define reference objects
    Dim ReferenceSlide As Slide
    Dim ReferenceSlides As Slides
    Dim ReferenceShape As Shape

    'define target objects
    Dim TargetSlide As Slide
    Dim TargetSlides As Slides
    Dim TargetShape As Shape

    'define other variables
    Dim i As Long


    'Setting-up presentations and slide collections
    Set ReferencePresentation = ActivePresentation
    With ReferencePresentation
        Set TargetPresentation = Presentations.Open(FileName:=.Path & "/Presentation B.pptm", _
                WithWindow:=msoFalse)
        Set ReferenceSlides = .Slides
    End With

    Set TargetSlides = TargetPresentation.Slides

    'Check slide count
    If ReferenceSlides.Count <> TargetSlides.Count Then
        'What's a desired behaviour for this case?
        'We can add slides to target presentation but it adds complexity
        Debug.Print "ERROR!" & vbTab & "Reference And Target slides counts are not equal!"
    Else
        '"mainloop" for slides
        For i = 1 To ReferenceSlides.Count
            Set ReferenceSlide = ReferenceSlides(i)
            Set TargetSlide = TargetSlides(i)

            'Check slide layout
            If ReferenceSlide.Layout <> TargetSlide.Layout Then
                'What's a desired behaviourfor this case?
                'We can change layout for target presentation but it adds complexity
                'But let's try to change a layout too, since we have an easy case in our example!
                Debug.Print "WARNING!" & vbTab & "Reference And Target slides layouts are not same!"
                TargetSlide.Layout = ReferenceSlide.Layout
            End If

            '"innerloop" for shapes (for placeholders actually)
            With ReferenceSlide
                For Each ReferenceShape In .Shapes
                    Set TargetShape = AcquireShape(ReferenceShape, TargetSlide, True)

                    If TargetShape Is Nothing Then
                        Debug.Print "WARNING!" & vbTab & "There's no shape like " & ReferenceShape.Name
                    ElseIf TargetShape.HasTextFrame Then
                        With TargetShape.TextFrame.TextRange
                            'paste text
                            .Text = ReferenceShape.TextFrame.TextRange.Text
                            'and options
                            .Font.Size = ReferenceShape.TextFrame.TextRange.Font.Size
                            .Font.Name = ReferenceShape.TextFrame.TextRange.Font.Name
                            .Font.Color.RGB = ReferenceShape.TextFrame.TextRange.Font.Color.RGB
                            '...
                        End With
                    End If
                Next
            End With
        Next
    End If

    'Save and close target presentation
    Call TargetPresentation.Save
    Call TargetPresentation.Close
End Sub


Function AcquireShape(ByRef ReferenceShape As Shape, ByRef TargetSlide As Slide, _
        Optional ByVal CreateIfNotExists As Boolean) As Shape
    Dim TargetShape As Shape

    With ReferenceShape
        'seek for existed shape
        For Each TargetShape In TargetSlide.Shapes
            If TargetShape.Width = .Width And TargetShape.Height = .Height And _
                    TargetShape.Top = .Top And TargetShape.Left = .Left And _
                    TargetShape.AutoShapeType = .AutoShapeType Then
                Set AcquireShape = TargetShape
                Exit Function
            End If
        Next

        'create new
        If CreateIfNotExists Then
            If .Type = msoPlaceholder Then
                Set AcquireShape = TargetSlide.Shapes.AddPlaceholder(.PlaceholderFormat.Type, .Left, .Top, .Width, .Height)
            Else
                Set AcquireShape = TargetSlide.Shapes.AddShape(.AutoShapeType, .Left, .Top, .Width, .Height)
            End If
        End If
    End With
End Function

输出:

我知道很难通过屏幕截图找到任何差异(甚至可以对其进行 Photoshop 处理，无论如何，为此目的存在一些差异)，但对于完整的答案，这里是:

结论:

如您所见，实现与您的愿望类似的目标并不是一项艰巨的任务，但解决方案的复杂性取决于输入和“假设”情况，因此一般来说没有捷径可以克服此任务(在我的拙见)。干杯!