如何缩放以适合在 PowerPoint 中添加到图像占位符中的图片?
How to scale to fit pictures, that are added into image placeholders in powerpoint?
在主布局中,我定义了添加图像的占位符,但我找不到缩放以适合它们的解决方案。图片占位符的原因是可以为不同的布局添加图片,而无需添加确切的位置属性(左、上、宽、高)
我当前的代码如下所示:
Sub InsertPictures
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\EAP.png", _LinkToFile:=msoTrue
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\DAP_01.png", LinkToFile:=msoTrue, _
End Sub
在下图中,您可以在左侧看到图片是如何添加图像占位符的,在右侧可以看到在适合时应该如何添加。
我找到了执行 "crop to fit" 的代码,但它仅在选中幻灯片时有效:
Sub cropFit()
Dim osld As Slide
Dim oshp As Shape
On Error Resume Next
Set osld = ActiveWindow.View.Slide
If Not osld Is Nothing Then
For Each oshp In osld.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderPicture Then
oshp.Select
CommandBars.ExecuteMso ("PictureFitCrop")
End If 'picture placeholder
End If 'placehoder
Next oshp
End If ' Slide selected
End Sub
如何更改代码,在使用上面的代码(子插入图片)添加图像后,图像会被裁剪以适合演示模式?
提前感谢您的帮助!
我们需要做的是获取图片占位符,并将图片分配给这些占位符。您将把您的文件名放在一个数组中,该数组可以容纳与占位符一样多的字符串(我在下面使用了 3 个,因为您说您有 3 个图片占位符)。然后我们将在这些占位符处插入图片并裁剪它们以适合。我借用了 here and here 中使用的概念。所以你的代码将是:
Sub InsertPictures()
Dim FileNames(1 To 3) As String, Shps As Shapes, i As Integer
Set Shps = ActivePresentation.Slides(1).Shapes
FileNames(1) = "U:\xyz\EAP.png"
FileNames(2) = "U:\xyz\DAP_01.png"
' Filenames(3) = "Blah Blah Blah"
i = 1
For Each Shp In Shps.Placeholders
' You only need to work on Picture place holders
If Shp.PlaceholderFormat.Type = ppPlaceholderPicture Then
With Shp
' Now add the Picture
Set s = Shps.AddPicture(FileNames(i), msoTrue, msoTrue, _
.Left, .Top, .Width, .Height)
' Insert DoEvents here specially for big files, or network files
' DoEvents halts macro momentarily until the
' system finishes what it's doing which is loading the picture file
DoEvents
s.Select
CommandBars.ExecuteMso ("PictureFitCrop")
i = i + 1
End With
End If
If (i > UBound(FileNames)) Then Exit For
If (FileNames(i) = "") Then Exit For
Next Shp
End Sub
谢谢大家的帮助!我设法用以下代码解决了这个问题:
Sub CropToFit()
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\EAP.png", _LinkToFile:=msoTrue
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\DAP_01.png", LinkToFile:=msoTrue, _
ActivePresentation.SlideShowWindow.view.Exit
Do Events
Dim osld As Slide
Dim oshp As Shape
On Error Resume Next
Set osld = ActiveWindow.view.Slide
If Not osld Is Nothing Then
For Each oshp In osld.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderPicture Then
oshp.Select
CommandBars.ExecuteMso ("PictureFitCrop")
End If 'picture placeholder
End If 'placehoder
Next oshp
End If ' Slide selected
End Sub
在主布局中,我定义了添加图像的占位符,但我找不到缩放以适合它们的解决方案。图片占位符的原因是可以为不同的布局添加图片,而无需添加确切的位置属性(左、上、宽、高)
我当前的代码如下所示:
Sub InsertPictures
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\EAP.png", _LinkToFile:=msoTrue
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\DAP_01.png", LinkToFile:=msoTrue, _
End Sub
在下图中,您可以在左侧看到图片是如何添加图像占位符的,在右侧可以看到在适合时应该如何添加。
我找到了执行 "crop to fit" 的代码,但它仅在选中幻灯片时有效:
Sub cropFit()
Dim osld As Slide
Dim oshp As Shape
On Error Resume Next
Set osld = ActiveWindow.View.Slide
If Not osld Is Nothing Then
For Each oshp In osld.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderPicture Then
oshp.Select
CommandBars.ExecuteMso ("PictureFitCrop")
End If 'picture placeholder
End If 'placehoder
Next oshp
End If ' Slide selected
End Sub
如何更改代码,在使用上面的代码(子插入图片)添加图像后,图像会被裁剪以适合演示模式?
提前感谢您的帮助!
我们需要做的是获取图片占位符,并将图片分配给这些占位符。您将把您的文件名放在一个数组中,该数组可以容纳与占位符一样多的字符串(我在下面使用了 3 个,因为您说您有 3 个图片占位符)。然后我们将在这些占位符处插入图片并裁剪它们以适合。我借用了 here and here 中使用的概念。所以你的代码将是:
Sub InsertPictures()
Dim FileNames(1 To 3) As String, Shps As Shapes, i As Integer
Set Shps = ActivePresentation.Slides(1).Shapes
FileNames(1) = "U:\xyz\EAP.png"
FileNames(2) = "U:\xyz\DAP_01.png"
' Filenames(3) = "Blah Blah Blah"
i = 1
For Each Shp In Shps.Placeholders
' You only need to work on Picture place holders
If Shp.PlaceholderFormat.Type = ppPlaceholderPicture Then
With Shp
' Now add the Picture
Set s = Shps.AddPicture(FileNames(i), msoTrue, msoTrue, _
.Left, .Top, .Width, .Height)
' Insert DoEvents here specially for big files, or network files
' DoEvents halts macro momentarily until the
' system finishes what it's doing which is loading the picture file
DoEvents
s.Select
CommandBars.ExecuteMso ("PictureFitCrop")
i = i + 1
End With
End If
If (i > UBound(FileNames)) Then Exit For
If (FileNames(i) = "") Then Exit For
Next Shp
End Sub
谢谢大家的帮助!我设法用以下代码解决了这个问题:
Sub CropToFit()
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\EAP.png", _LinkToFile:=msoTrue
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\DAP_01.png", LinkToFile:=msoTrue, _
ActivePresentation.SlideShowWindow.view.Exit
Do Events
Dim osld As Slide
Dim oshp As Shape
On Error Resume Next
Set osld = ActiveWindow.view.Slide
If Not osld Is Nothing Then
For Each oshp In osld.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderPicture Then
oshp.Select
CommandBars.ExecuteMso ("PictureFitCrop")
End If 'picture placeholder
End If 'placehoder
Next oshp
End If ' Slide selected
End Sub