将文本范围从1个功率点传输到另一个功率点以更改模板

Question

我是Powerpoint VBA的新手,想知道是否有一种简短的方法可以将一个文本范围从PowerPoint A传输到另一个位于Powerpoint B中的文本范围.

第a1页= b1

第a2页= b2

第a3页= b3

模板正在改变,我需要调整100个幻灯片的5个powerpoint,所以我认为使用这个解决方案会更容易.

预先感谢您的帮助.

精度:我不想复制和粘贴文本范围,而是复制范围内的文本以将其置于新范围内.请在下面找到我已经拥有的代码,但它并没有'将它粘贴到我的新范围内.

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

简短回答：

是否有一种简单的方法可以将 PowerPoint A 中的一个文本范围传输到 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 处理，无论如何，为此目的存在一些差异），但对于完整的答案，这里是：

结论：

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