将裁剪的图像插入到 PowerPoint 幻灯片中以获取文件夹中选定的图像。每张幻灯片最多 6 张图片？

Question

我有数百张用于单个样本的照片，需要裁剪然后插入到 PowerPoint 幻灯片中。在纵向模式下，每张幻灯片六张照片，所有照片的文本标签相同。 PowerPoint 相册最多只能导入 4 张照片。 我发现一些代码与自定义占位符布局相结合，该布局计算我为该特定示例选择的图像数量，然后为每张新幻灯片放置一张照片。但是，每张幻灯片我需要 6 张照片。以下代码不包含裁剪代码。

谁能帮忙？

代码贴在下面

Public Function GetLayout( _
LayoutName As String, _
Optional ParentPresentation As Presentation = Nothing) As CustomLayout

If ParentPresentation Is Nothing Then
    Set ParentPresentation = ActivePresentation
End If

Dim oLayout As CustomLayout
For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
    If oLayout.Name = LayoutName Then
        Set GetLayout = oLayout
        Exit For
    End If
Next
End Function

Sub ImportABunch2()
Dim i As Long
Dim oSlide As Slide
Dim oPicture As Shape, oContentHolder As Shape


Dim dlgOpen As FileDialog

Set dlgOpen = Application.FileDialog(Type:=msoFileDialogOpen)
With dlgOpen
    .AllowMultiSelect = True
    .Show
End With

If dlgOpen.SelectedItems.Count = 0 Then Exit Sub

For i = 1 To dlgOpen.SelectedItems.Count

''Dim oSlides As Slides, oSlide As Slide
Set oSlides = ActivePresentation.slides
Set oSlide = oSlides.AddSlide(oSlides.Count + 1, GetLayout("Smiley"))
    For Each oContentHolder In oSlide.Shapes
        If oContentHolder.Type = msoPlaceholder And oContentHolder.PlaceholderFormat.ContainedType = msoAutoShape Then
            Set oPicture = oSlide.Shapes.AddPicture(FileName:=dlgOpen.SelectedItems(i), _
                LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                Left:=0, Top:=0, Width:=100, Height:=100)
              
            GoTo NextSlide
        End If
    Next

NextSlide:
Next i
End Sub

Answer 1

此代码有效：

Sub ImportABunch3()

Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape

Dim lCurrentRound As Long
lCurrentRound = 1

' Edit these to suit:
'strPath = "C:\Users\"

strFileSpec = "*.jpg"

strTemp = Dir(strPath & strFileSpec)

Do While strTemp <> ""

If lCurrentRound = 1 Then   ' add a new slide
    Set oSld = ActivePresentation.slides.Add(ActivePresentation.slides.Count + 
1, ppLayoutCustom)
End If
        Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
        LinkToFile:=msoFalse, _
        SaveWithDocument:=msoTrue, _
        Left:=0, _
        Top:=0, _
        Width:=-1, _
        Height:=-1)

    ' Edit the Left/Top values below if you want to place
    ' the images in specific locations
         Select Case lCurrentRound
        Case 1
            oPic.Left = 25
            oPic.Top = 30

        Case 2
            oPic.Left = 260
            oPic.Top = 30

        Case 3
            oPic.Left = 25
            oPic.Top = 250

        Case 4
            oPic.Left = 260
            oPic.Top = 250

        Case 5
            oPic.Left = 25
            oPic.Top = 470
        
        Case 6
            oPic.Left = 260
            oPic.Top = 470

        End Select

If lCurrentRound = 6 Then
    lCurrentRound = 1
Else
    lCurrentRound = lCurrentRound + 1
End If

strTemp = Dir

''Call Align_all_images

Loop

End Sub