将文本范围从 1 个电源点转移到另一个电源点以更改模板
Transferring text range from 1 power point to another to change template
我对 Powerpoint 还很陌生 VBA，想知道是否有一种简短的方法可以将一个文本范围从 PowerPoint A 按特定顺序传输到位于 Powerpoint B 中的另一个文本范围。
页面 a1 = b1
页面 a2 = b2
页面 a3 = b3
模板正在更改，我需要调整 100 张幻灯片的 5 个幻灯片，所以我认为使用此解决方案会更容易。
预先感谢您的帮助。
PRECISION : 我不想复制和粘贴文本范围，而是复制范围内的文本以将其放入新范围内。请在下面找到我已有的代码，但它没有将其粘贴到我的新范围内。
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
简答：
Is there're a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B?
我认为没有捷径可走，但让我们先尝试一下吧！
长答案：
注意：此解决方案不是基于您想要的行为（因为我不清楚并且有越来越多的 "what if" 案例），而是基于类似的问题，所以我认为它是合法的。无论如何，这是一个很好的基础。
输入：
我不知道你的演示文稿到底是什么样子，所以我做了一个参考（Presentation A）和一个"broken"（Presentation B).让我们来看看它们：
演示文稿 A（5 张幻灯片：1x"Title slide" 有 2 个三角形，3x"Title and Content" 幻灯片，1x"Section Header" 滑动）：
演示文稿 B（5 张幻灯片：1x"Title slide" 缺少三角形，3x"Title and Content" 幻灯片带有 empty/without 形状（占位符），1x"Blank" 幻灯片（布局错误）：
两个演示文稿都在同一个文件夹中：
期望的行为：
某种同步，如果我们错过了一个形状 - 然后创建一个并将所需的文本放入其中，如果有的话 - 仅放置所需的文本（基于演示文稿 A 的形状）。逻辑上有"what if"个案例：
- "What if"每个演示文稿中的幻灯片数量不相等？那么按什么顺序比较幻灯片呢？ （在我们的例子中，数字是相等的，因此在代码中我们删除该部分并逐对比较幻灯片）。
- "What if" 比较的幻灯片有不同的布局？ （在我们的案例中空白布局的差异，所以我们可以轻松处理它，但我们通常应该怎么做？）
- ...以及此解决方案中未考虑的许多其他情况
逻辑：
逻辑简单明了。我们例程的入口点在 Presentation A 中，因为它是我们的参考文件。从那时起，我们获得了对 Presentation B 的引用（打开它时），并在两个循环中开始迭代（通过每对幻灯片和参考形状）。
如果我们通过参考形状找到 "broken"（或者不是这样，没有检查）形状 - 我们将文本和一些选项放入其中，否则创建一个新的形状（或占位符）。
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 处理，无论如何为此目的有一些差异），但要获得完整答案，请看这里：
结论：
如您所见，实现与您的愿望类似的东西并不是一项艰巨的任务，但解决方案的复杂性取决于输入和 "what if" 个案例，因此没有捷径可完成此任务一般（以我的拙见）。干杯！
你的问题有很多不同的解释，下面是我试图回答我认为问题是什么。此解决方案有多个阶段。
1.确保我们保存我们写的VBA
首先，我们必须假设一个主演示文稿，该演示文稿将保存要复制到所有其他演示文稿的值。这将需要保存为启用宏的演示文稿 (pptm)，以便我们保存 VBA。这是通过 File > Save-As 完成的，在 select 保存位置时，在 Save as type 框中选择 PowerPoint Macro-Enabled Presentation。
2。启用 Windows 脚本 运行time
在我们现在拥有的 pptm 'master' 演示文稿中，打开 VBA IDE (Alt+F11)。在菜单栏中 select Tools > References... 并从显示的列表中勾选 Microsoft Scripting Runtime。单击 OK 关闭引用对话框并记住您的勾号。这是代码中某些错误处理所必需的，它会在尝试打开演示文稿之前检查演示文稿是否存在。
3。插入提供的代码
右键单击右上区域（项目资源管理器）中的 VBAProject 和 select Insert > 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
错误处理：
MsgBox "There was an error: - " & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description, vbOKOnly + vbExclamation, "Error"
Err.Clear
结束子
4。自定义代码
您需要添加更改的路径和位置，然后它应该 运行。
我对 Powerpoint 还很陌生 VBA，想知道是否有一种简短的方法可以将一个文本范围从 PowerPoint A 按特定顺序传输到位于 Powerpoint B 中的另一个文本范围。
页面 a1 = b1
页面 a2 = b2
页面 a3 = b3
模板正在更改，我需要调整 100 张幻灯片的 5 个幻灯片，所以我认为使用此解决方案会更容易。
预先感谢您的帮助。
PRECISION : 我不想复制和粘贴文本范围，而是复制范围内的文本以将其放入新范围内。请在下面找到我已有的代码，但它没有将其粘贴到我的新范围内。
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
简答：
Is there're a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B?
我认为没有捷径可走，但让我们先尝试一下吧！
长答案：
注意：此解决方案不是基于您想要的行为（因为我不清楚并且有越来越多的 "what if" 案例），而是基于类似的问题，所以我认为它是合法的。无论如何，这是一个很好的基础。
输入：
我不知道你的演示文稿到底是什么样子，所以我做了一个参考（Presentation A）和一个"broken"（Presentation B).让我们来看看它们：
演示文稿 A（5 张幻灯片：1x"Title slide" 有 2 个三角形，3x"Title and Content" 幻灯片，1x"Section Header" 滑动）：
演示文稿 B（5 张幻灯片：1x"Title slide" 缺少三角形，3x"Title and Content" 幻灯片带有 empty/without 形状（占位符），1x"Blank" 幻灯片（布局错误）：
两个演示文稿都在同一个文件夹中：
期望的行为：
某种同步，如果我们错过了一个形状 - 然后创建一个并将所需的文本放入其中，如果有的话 - 仅放置所需的文本（基于演示文稿 A 的形状）。逻辑上有"what if"个案例：
- "What if"每个演示文稿中的幻灯片数量不相等？那么按什么顺序比较幻灯片呢？ （在我们的例子中，数字是相等的，因此在代码中我们删除该部分并逐对比较幻灯片）。
- "What if" 比较的幻灯片有不同的布局？ （在我们的案例中空白布局的差异，所以我们可以轻松处理它，但我们通常应该怎么做？）
- ...以及此解决方案中未考虑的许多其他情况
逻辑：
逻辑简单明了。我们例程的入口点在 Presentation A 中，因为它是我们的参考文件。从那时起，我们获得了对 Presentation B 的引用（打开它时），并在两个循环中开始迭代（通过每对幻灯片和参考形状）。 如果我们通过参考形状找到 "broken"（或者不是这样，没有检查）形状 - 我们将文本和一些选项放入其中，否则创建一个新的形状（或占位符）。
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 处理，无论如何为此目的有一些差异），但要获得完整答案，请看这里：
结论：
如您所见，实现与您的愿望类似的东西并不是一项艰巨的任务，但解决方案的复杂性取决于输入和 "what if" 个案例，因此没有捷径可完成此任务一般（以我的拙见）。干杯！
你的问题有很多不同的解释，下面是我试图回答我认为问题是什么。此解决方案有多个阶段。
1.确保我们保存我们写的VBA
首先，我们必须假设一个主演示文稿，该演示文稿将保存要复制到所有其他演示文稿的值。这将需要保存为启用宏的演示文稿 (pptm)，以便我们保存 VBA。这是通过 File > Save-As 完成的，在 select 保存位置时，在 Save as type 框中选择 PowerPoint Macro-Enabled Presentation。
2。启用 Windows 脚本 运行time
在我们现在拥有的 pptm 'master' 演示文稿中，打开 VBA IDE (Alt+F11)。在菜单栏中 select Tools > References... 并从显示的列表中勾选 Microsoft Scripting Runtime。单击 OK 关闭引用对话框并记住您的勾号。这是代码中某些错误处理所必需的，它会在尝试打开演示文稿之前检查演示文稿是否存在。
3。插入提供的代码
右键单击右上区域（项目资源管理器）中的 VBAProject 和 select Insert > 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
错误处理： MsgBox "There was an error: - " & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description, vbOKOnly + vbExclamation, "Error" Err.Clear 结束子
4。自定义代码
您需要添加更改的路径和位置，然后它应该 运行。