如何使用修改后的名称将形状组作为照片保存到文件对话框路径

Question

到目前为止，这是我的宏（有关以下问题的详细信息）：

Sub saveWithLogo()
Dim fd As FileDialog
Dim directory As String
Dim vrtSelectedItem As Variant
Dim osld As Slide
Dim oPic As Shape
Dim osldGroup As Slide
Dim oshp As Shape
Dim logoPic As Shape
Dim i As Integer
Dim num_pics As Integer
Dim fso As New FileSystemObject
Dim fileName As String
Dim filePath As String

Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd     'Get pictures from file dialog, add logo to each picture
    If .Show = -1 Then
        For Each vrtSelectedItem In .SelectedItems
            numPics = .SelectedItems.Count
            fileName = fso.GetBaseName(vrtSelectedItem)
            filePath = fso.GetParentFolderName(vrtSelectedItem)
            Set osld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
            Set oPic = osld.Shapes.AddPicture(vrtSelectedItem, msoFalse, msoTrue, 50, 50)
            logoWidth = 6.18 * 28.3
            logoHeight = 1.4 * 28.3
            Set logoPic = osld.Shapes.AddPicture("C:\Pictures\Logo\" & "logo.png", lsoFalse, msoTrue, 50, 50, logoWidth, logoHeight)
        Next vrtSelectedItem
    End If
End With

For i = 1 To numPics    'Groups pictures on slide
    Set osldGroup = ActivePresentation.Slides(i)
    ActivePresentation.Slides(i).Select
    ActiveWindow.Selection.Unselect
    For Each oshp In osldGroup.Shapes
    If oshp.Type = msoPicture Then oshp.Select Replace:=False
    Next oshp
    With ActiveWindow.Selection.ShapeRange
    If .Count > 1 Then .Group
    End With

    'ActivePresentation.Slides(i).Select
    'Call ActiveWindow.Selection.SlideRange.Shapes.Export(filePath & fileName & "_with logo", ppShapeFormatJPG, 3072)

Next i

Set fd = Nothing
End Sub

从这里我想从每张幻灯片中拍摄分组照片并将其保存到 fd 所选项目的文件位置，并将每张分组照片另存为原始所选项目的修改版本。

因此，如果我选择了项目："photo1.jpg"、"thisphoto.png" 和 "somedescriptivename.jpg" 都来自同一文件夹（例如 "C:\Documents\myproject\images\" 我希望它保存新的分组照片"C:\Documents\myproject\images\" 为 "photo1_with logo.jpg"、"thisphoto_with logo.jpg" 和 "somedescriptivename_with logo.jpg"。

现在我可以成功地将所有图片放到幻灯片上并将它们分组。我不知道如何为 .SelectedItems 中的每个 vrtSelectedItem 获取唯一的字符串名称。我知道我可以改变

 Dim fileName As String

到

 Dim fileName() As String

为了以这种方式保存它，但我不知道如何在 for 循环中引用它（fso.GetBaseName（vrtSelectedItem.Index）？）。而且我在尝试保存组时也收到错误 "Compile error: Method or data member not found"。

Answer 1

可能会解决问题。它没有完全尝试，因为最终导出方法在我当前的系统中引发了 PowerPoint 转换器安装问题。但除此之外没有像 "Compile error: Method or data member not found"

这样的错误

可以试试collection

Option Base 1 
'
'
' then in Declaration
Dim FileName As New Collection
Dim FilePath As New Collection
Dim FinalName As String
'
'
'the in For Each vrtSelectedItem In .SelectedItems

            FileName.Add fso.GetBaseName(vrtSelectedItem)
            FilePath.Add fso.GetParentFolderName(vrtSelectedItem)
'
'
'
' then in For i = 1 To numPics after End With

    FinalName = FilePath(i) & "\" & FileName(i) & "_with logo"
    ActivePresentation.Slides(i).Select
    'MsgBox FinalName
    ActivePresentation.Slides(i).Export FinalName , ppShapeFormatJPG, 3072

无法理解您是否将之前保存的图片放在幻灯片中并在上面放置徽标？如果就这么简单，那么可以尝试使用单循环

进行更简单的替代

Sub saveWithLogo()
Dim fd As FileDialog
Dim directory As String
Dim vrtSelectedItem As Variant
Dim osld As Slide
Dim oPic As Shape
Dim osldGroup As Slide
Dim oshp As Shape
Dim logoPic As Shape
Dim i As Integer
Dim num_pics As Integer
Dim fso As New FileSystemObject
Dim FileName As String
Dim FilePath As String

Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd     'Get pictures from file dialog, add logo to each picture
If .Show = -1 Then
   For Each vrtSelectedItem In .SelectedItems
   numPics = .SelectedItems.Count
   FileName = fso.GetBaseName(vrtSelectedItem)
   FilePath = fso.GetParentFolderName(vrtSelectedItem)
   Set osld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
   Set oPic = osld.Shapes.AddPicture(vrtSelectedItem, msoFalse, msoTrue, 50, 50)
   osldno = ActivePresentation.Slides.Count
   logoWidth = 6.18 * 28.3
   logoHeight = 1.4 * 28.3
   Set logoPic = osld.Shapes.AddPicture("C:\foxpro2\vtools\logo.bmp", lsoFalse, msoTrue, 50, 50, logoWidth, logoHeight)
    osld.Select
    ActiveWindow.Selection.Unselect
        For Each oshp In osld.Shapes
        If oshp.Type = msoPicture Then oshp.Select Replace:=False
        Next oshp
        With ActiveWindow.Selection.ShapeRange
        If .Count > 1 Then .Group
        End With
        FinalName = FilePath & "\" & FileName & "_with logo"
        'MsgBox FinalName
   osld.Export FinalName & "_with logo", ppShapeFormatJPG ' , 3072
   Next vrtSelectedItem
   End If
End With

Set fd = Nothing
End Sub

Answer 2

求古玩或者有同样问题的。这是我从 Ahmed 的回答中学到的最后成功的宏。

我添加了图像缩放，因为输出尺寸比原始尺寸小得多。

Sub saveWithLogo()

Dim fd As FileDialog
Dim directory As String
Dim vrtSelectedItem As Variant
Dim osld As Slide
Dim oPic As Shape
Dim osldGroup As Slide
Dim oshp As Shape
Dim logoPic As Shape
Dim i As Integer
Dim num_pics As Integer
Dim fso As New FileSystemObject
Dim fileName As New Collection
Dim filePath As New Collection
Dim finalName As String

Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd     'Get pictures from file dialog, add logo to each picture
    If .Show = -1 Then
        For Each vrtSelectedItem In .SelectedItems
            numPics = .SelectedItems.Count
            fileName.Add fso.GetBaseName(vrtSelectedItem)
            filePath.Add fso.GetParentFolderName(vrtSelectedItem)
            Set osld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
            Set oPic = osld.Shapes.AddPicture(vrtSelectedItem, msoFalse, msoTrue, 50, 50)
            With oPic
                .LockAspectRatio = msoTrue
                .ScaleWidth 1.875, msoTrue
            End With
            logoWidth = 6.18 * 28.3
            logoHeight = 1.4 * 28.3
            Set logoPic = osld.Shapes.AddPicture("C:\Pictures\Logo Images\" & "logo.png", lsoFalse, msoTrue, 100, 85, logoWidth, logoHeight)
            With logoPic
                .LockAspectRatio = msoTrue
                .ScaleWidth 0.005 * oPic.Width, msoTrue
            End With
            Set oPic = Nothing
            Set logoPic = Nothing
        Next vrtSelectedItem
    End If
End With

For i = 1 To numPics    'Groups pictures on slide
    Set osldGroup = ActivePresentation.Slides(i)
    ActivePresentation.Slides(i).Select
    ActiveWindow.Selection.Unselect
    For Each oshp In osldGroup.Shapes
    If oshp.Type = msoPicture Then oshp.Select Replace:=False
    Next oshp
    With ActiveWindow.Selection.ShapeRange
    If .Count > 1 Then
    .Group
    End If
    End With
Next i

Dim ap As Presentation: Set ap = ActivePresentation
Dim sl As Slide
Dim shGroup As ShapeRange
For Each sl In ap.Slides
    ActiveWindow.View.GotoSlide (sl.SlideIndex)
    sl.Shapes.SelectAll
    Set shGroup = ActiveWindow.Selection.ShapeRange
    shGroup.Export filePath(sl.SlideIndex) & "\" & fileName(sl.SlideIndex) & "_with logo" & ".jpg", ppShapeFormatJPG, , , ppScaleXY
Next

Set fd = Nothing
Dim v As Long
For v = 1 To Application.ActivePresentation.Slides.Count
    ActivePresentation.Slides.Range(1).Delete
Next v

End Sub

如何使用修改后的名称将形状组作为照片保存到文件对话框路径

How to save shape groups as photo to fileDialog path with amended name

powerpoint

vba