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

Question

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

页面a1 = b1

Page a2 = b2

页面a3 = b3

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

提前感谢您的帮助。

PRECISION：我不想复制和粘贴文本范围，而是复制范围内的文本以将其放入新范围内。请在下面找到我已经拥有的代码，但它没有＆＃39;将其粘贴到我的新范围内。

.Container2 {
  border: 1px solid black; // enable this is for test container border
  display: table;
    text-align: center;
}

Answer 1

简答：

  

将一个文本范围从PowerPoint A转移到位于Powerpoint B中的另一个文本范围是否有简短的方法？

我认为没有简短的方法可以做到，但让我们先尝试一下！

长答案：

注意：此解决方案不是基于您期望的行为（因为我不清楚并且有很多甚至更多“假设”案例），但在类似问题上，所以我认为这是合法的。无论如何，这是一个良好的基础开始。

输入：

我不知道你的演示文稿是什么样的，所以我做了一个引用（ Presentation A ）和一个“破坏”的（ Presentation B ）。我们来看看它们：

• 演示文稿A （5张幻灯片：带有2个三角形形状的1x“标题幻灯片”，3个“标题和内容”幻灯片，1个“标题标题”幻灯片）：

• 演示文稿B （5张幻灯片：1x“标题幻灯片”缺少三角形形状，3x“标题和内容”幻灯片，空/无形状（占位符），1x“空白”幻灯片（错误的布局））：

• 两个演示文稿都在同一个文件夹中：

  

期望的行为：

某种同步，如果我们错过了一个形状 - 然后创建一个并将所需的文本放到它上面（如果有的话） - 仅放置所需的文本（基于演示文稿A的形状）。逻辑中有一些“假设”案例：

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

逻辑：

逻辑简单明了。我们例程的入口点在 Presentation A 中，因为它是我们的参考文件。从那时起，我们获得对 Presentation 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

输出：

我知道很难通过屏幕截图找到任何差异（它甚至可以照片化，无论如何都有一些不同之处），但对于完整的答案，这里是：

结论：

如你所见，实现类似于你的愿望并不是一项艰巨的任务，但解决方案的复杂性取决于输入和“假设”情况，因此一般来说，没有简短的方法可以克服这个任务。我的拙见）。干杯！

Answer 2

你的问题有许多不同的解释，下面是我试图回答我认为的问题。这个解决方案有很多阶段。

<强> 1。确保我们保存我们编写的VBA

首先，我们必须假设一个主要演示文稿，即将要复制到所有其他值的值。这将需要保存为启用宏的演示文稿（pptm）以允许我们保存我们的VBA。这是通过File＆gt;完成的。 Save-As并在选择保存位置时，在PowerPoint Macro-Enabled Presentation框中选择Save as type。

<强> 2。启用Windows脚本运行时

在pptm＆＃39; master＆＃39;我们现在的演示文稿，打开VBA IDE（Alt + F11）。在菜单栏中选择Tools＆gt; References...并从显示的列表中勾选Microsoft Scripting Runtime。单击OK以关闭引用对话框并记住您的勾选。这是代码中的一些错误处理所需要的，它会在尝试打开它之前检查表示是否存在。

第3。插入提供的代码

右键单击右上角区域（项目浏览器）中的VBAProject，然后选择Insert＆gt; Module。

在主编辑区粘贴下面（我添加了评论来描述正在发生的事情）： -

Option Explicit

Public Sub Update()
Dim AryPresentations(4) As String
Dim LngPID              As Long
Dim FSO                 As New FileSystemObject
Dim PP_Src              As Presentation
Dim PP_Dest             As Presentation
Dim Sld_Src             As Slide
Dim Sld_Dest            As Slide
Dim Shp_Src             As Shape
Dim Shp_Dest            As Shape
Dim LngFilesMissing     As Long
Dim BlnWasOpen          As Boolean

'If there is an error, this will handle it and stop the process
On Error GoTo ErrorHandle

'Increase the size of AryPresentations and and the paths as shown in the example below
AryPresentations(0) = "C:\Users\garye\Desktop\PP2.pptx"
AryPresentations(1) = "C:\Users\garye\Desktop\PP3.pptx"
AryPresentations(2) = "C:\Users\garye\Desktop\PP4.pptx"
AryPresentations(3) = "C:\Users\garye\Desktop\PP5.pptx"
AryPresentations(4) = "C:\Users\garye\Desktop\PP6.pptx"

'PP_Src is this, our 'master' presentation
Set PP_Src = ActivePresentation

'This loops through each item in AryPresentations
For LngPID = 0 To UBound(AryPresentations, 1)

    'We rememeber if you had it open already as if you did, then we won't close it when we are done
    BlnWasOpen = False

    'Check all currently open presentations to see if one if the presentation we are due to update
    For Each PP_Dest In PowerPoint.Presentations
        If Trim(UCase(PP_Dest.FullName)) = Trim(UCase(AryPresentations(LngPID))) Then Exit For
    Next

    'If it was not already open, check it exists and if it does, then open in
    If PP_Dest Is Nothing Then
        If FSO.FileExists(AryPresentations(LngPID)) Then
            Set PP_Dest = PowerPoint.Presentations.Open(AryPresentations(LngPID))
        End If
    Else
        BlnWasOpen = True
    End If

    If PP_Dest Is Nothing Then
        Debug.Print "File note found"
        LngFilesMissing = LngFilesMissing + 1
    Else
        'The below connects to the slide (Sld_Src) you want to pick up from, the shape (Shp_Src) you want to pick up from and then
        'places it in the slide (Sld_Dest) you want it to go to into the shape (Shp_Dest) you want it to go in to
        Set Sld_Src = PP_Src.Slides(1)
            Set Sld_Dest = PP_Dest.Slides(1)
                Set Shp_Src = Sld_Src.Shapes(1)
                    Set Shp_Dest = Sld_Dest.Shapes(1)
                        Shp_Dest.TextFrame.TextRange.Text = Shp_Src.TextFrame.TextRange.Text
                    Set Shp_Dest = Nothing
                Set Shp_Src = Nothing
            Set Sld_Dest = Nothing
        Set Sld_Src = Nothing
        'Repeat the above for each piece of text to copy

        'Finally save the changes
        PP_Dest.Save

        'Close the presentation if it was not already open
        If Not BlnWasOpen Then PP_Dest.Close

    End If
Next

MsgBox "Process complete. Number of missing files: " & LngFilesMissing, vbOKOnly + vbInformation, "Complete"

Exit Sub

ErrorHandle：     MsgBox＆＃34;出现错误： - ＆＃34; ＆安培; vbNewLine＆amp; vbNewLine＆amp; Err.Number＆amp; ＆＃34;：＆＃34; ＆安培; Err.Description，vbOKOnly + vbExclamation，＆＃34;错误＆＃34;     Err.Clear     结束子

<强> 4。自定义代码

您想要添加更改的路径和位置，然后应该运行。