Как сохранить группы фигур в виде фотографии в файлDialog path с измененным именем

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

Отсюда я хочу взять сгруппированную фотографию с каждого слайда и сохранить ее в папке с файломВыберите выбранные элементы и сохраните каждую сгруппированную фотографию как исправленную версию исходного выбранного элемента.

Так что, если я выбрал элементы: "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 ".

В настоящее время я могу успешно разместить все изображения на слайдах и сгруппировать их. Я не знаю, как получить уникальное имя строки для каждого vrtSelectedItem в .SelectedItems.Я знаю, что могу изменить

 Dim fileName As String

на

 Dim fileName() As String

, чтобы сохранить его таким образом, но я не знаю, как ссылаться на это в цикле for (fso.GetBaseName (vrtSelectedItem.Index)?). ИЯ также получаю сообщение об ошибке «Ошибка компиляции: метод или элемент данных не найден» при попытке сохранить группу.

Answer 1

Для любопытных или тех, у кого такая же проблема. Вот последний успешный макрос с тем, что я узнал из ответа Ахмеда.

Я добавил масштабирование изображения, поскольку выходной размер был намного меньше исходного.

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

Answer 2

Это может решить проблему. Это не полностью испробовано, так как метод Final Export создает проблему с установкой конвертера PowerPoint в моей нынешней системе. Но в противном случае нет ошибки типа «Ошибка компиляции: метод или элемент данных не найден»

Можно просто попробовать коллекцию

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