共享文件时保留链接图像的Powerpoint代码

Question

在我的Powerpoint中，有链接到文件夹的图像。我需要将其发送给无权访问该文件夹的用户。我需要图像来保留当前内容。

我尝试手动复制并重新粘贴为图像AS PICTURE，然后发送PowerPoint，这有效，并保留了图像中的内容和日期设置。

当我有 32 个 PowerPoint 时，我如何以编程方式执行此操作？

Answer 1

这是一个有趣的挑战！

CopyPictures宏确实是您唯一需要的宏，但我包括了我用来设置和调试整个情况的其他两个宏。

Option Explicit
Sub CopyPictures()
Dim currentSlide As Slide
For Each currentSlide In ActivePresentation.Slides
Dim currentShape As Shape
For Each currentShape In currentSlide.Shapes
If currentShape.Type = msoLinkedPicture Then
'https://learn.microsoft.com/en-us/office/vba/api/powerpoint.shapes.addpicture
currentSlide.Shapes.AddPicture _
currentShape.LinkFormat.SourceFullName, _
msoFalse, msoTrue, _
currentShape.Left, currentShape.Top, _
currentShape.Width, currentShape.Height
currentShape.Delete
End If
Next currentShape
Next currentSlide
End Sub

CopyPictures宏循环遍历PowerPoint每张幻灯片中的每个形状，并说如果它正在检查的当前形状具有类型msoLinkedPicture，它将简单地使用该图片基于的链接将该图片重新添加到PowerPoint，而是选择将图片与文档一起保存为msoPicture！新图片将放置在同一位置，并缩放以匹配当前图片。最后，它删除了图片的"旧"链接版本，因为它已被替换。

---

AddLinkedPicture宏用于将链接的图片添加到我的活动幻灯片，然后我使用第二个宏ShapeTypeDebug，以确保我添加的图片具有正确的类型msoLinkedPicture。

可以使用ShapeTypeDebug宏检查当前幻灯片上是否有任何形状是图片。我在运行CopyPictures宏之前和之后使用它来确保图片被正确"转换"。

Sub AddLinkedPicture()
'https://learn.microsoft.com/en-us/office/vba/api/powerpoint.shapes.addpicture
ActiveWindow.View.Slide.Shapes.AddPicture "C:UsersPublicDownloadsUntitled.png", msoTrue, msoFalse, 100, 100
End Sub
Sub ShapeTypeDebug()
Dim currentShape As Shape
For Each currentShape In ActiveWindow.View.Slide.Shapes
'https://learn.microsoft.com/en-us/dotnet/api/microsoft.office.core.msoshapetype?view=office-pia
Select Case currentShape.Type
Case 11
MsgBox Chr(34) & currentShape.Name & Chr(34) & " is a msoLinkedPicture"
Case 13
MsgBox Chr(34) & currentShape.Name & Chr(34) & " is a msoPicture "
End Select
Next currentShape
End Sub

请注意，我使用的方法不会复制当前图片，因此如果您在 PowerPoint 中对其进行了其他编辑，我的方法将丢失该编辑。

Answer 2

对于分发演示文稿，我认为您可能已经拥有了最好的解决方案，但这里有另一个在某些情况下有用的解决方案。

PowerPoint几乎总是会创建完全路径的链接，但如果链接只是文件名，没有路径，它将(通常(在与PPT/PPTX本身相同的文件夹中查找图像。

因此，如果您愿意分发链接的图像以及PowerPoint文件，并且可以让收件人将它们全部放在一个文件夹中，则您需要做的就是设置链接图片的。LinkFormat.SourceFullName 到只有原始图像文件名，没有路径。

显然，这不会那么容易分发，但由于它不会改变图片，而是链接路径，因此它会保留您可能已应用于图像的任何动画、替代文本、标签或其他异常格式设置。

另一个也许是最简单的技巧是在插入图像时选择链接和嵌入，而不仅仅是链接。然后，当磁盘上的原始图像更改时，PPT 将更新演示文稿中的图像，但如果链接断开，则使用嵌入的副本。

Answer 3

@Marcucciboy2的第一个解决方案是一个很好的方法，但不涵盖形状组中的图片。此外，添加带有cid：image001.jpg@01D5DDD1.4B33D890等来源的链接图片似乎在问题。

因此，我增强了代码：

Option Explicit
Sub CopyPictures()
Dim currentSlide As Slide
For Each currentSlide In ActivePresentation.Slides
Dim currentShape As Shape
For Each currentShape In currentSlide.Shapes
HandleShape currentSlide:=currentSlide, currentShape:=currentShape 
Next currentShape
Next currentSlide
End Sub
Private Sub HandleShape(currentSlide As Slide, currentShape As Shape)
If currentShape.Type = msoGroup Then
Dim groupNames() As String
ReDim Preserve groupNames(1 To currentShape.GroupItems.Count + 1)
Dim groupIndex As Integer
groupIndex = 0
Dim shapeWasCopied As Boolean
shapeWasCopied = False
Dim groupShape As Shape
For Each groupShape In currentShape.GroupItems
groupIndex = groupIndex + 1
groupNames(groupIndex) = groupShape.Name
If groupShape.Type = msoLinkedPicture Then
HandleShape currentSlide:=currentSlide, currentShape:=groupShape
shapeWasCopied = True
End If
Next groupShape
If (shapeWasCopied) Then
currentSlide.Shapes.Range(groupNames).Group
End If
ElseIf currentShape.Type = msoLinkedPicture Then
Dim newShape As Object
Dim newName As String
newName = currentShape.Name
currentShape.Copy
Set newShape = currentSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture, DisplayAsIcon:=msoFalse, Link:=msoFalse)
With newShape
.Width = currentShape.Width
.Height = currentShape.Height
.Left = currentShape.Left
.Top = currentShape.Top
End With
currentShape.Delete
newShape.Name = newName
Application.CutCopyMode = False
End If
End Sub