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 \”，我希望将其保存将新的照片分组为“ C1 \ 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）？）。尝试保存组时，还会出现错误“编译错误：未找到方法或数据成员”。

Answer 1

它可以解决问题。由于“最终导出”方法在我的当前系统中引发了PowerPoint转换器安装问题，因此尚未完全尝试。但是否则，不会出现诸如“编译错误：未找到方法或数据成员”之类的错误

可以尝试收集

@Rule
public final ServiceTestRule mServiceRule = new ServiceTestRule();

private MyKeyboard retrieveMyKeyboardInstance(IBinder binder) {
    try {
        Class wrapperClass = Class.forName("android.inputmethodservice.IInputMethodWrapper");
        Field mTargetField = wrapperClass.getDeclaredField("mTarget");
        mTargetField.setAccessible(true);

        WeakReference<MyKeyboard> weakReference = (WeakReference<MyKeyboard>) mTargetField.get(binder);
        return weakReference.get();
    } catch (Exception e) {
        throw new RuntimeException(e);
    }
}

public void validateEditTextWithKeyboardInput() throws TimeoutException {
    ...
    Intent serviceIntent = new Intent(InstrumentationRegistry.getTargetContext(), MyKeyboard.class);
    IBinder binder = mServiceRule.bindService(serviceIntent);
    MyKeyboard keyboard = retrieveMyKeyboardInstance(binder);

    ...
}

不知道您是否要在幻灯片中放置以前保存的图片并在其上放置徽标？如果那么简单，则可以尝试使用单循环更简单的替代方法

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

Answer 2

对于古玩或具有相同问题的古玩。这是我从艾哈迈德的答案中学到的最后一个成功的宏。

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

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

如何将形状组另存为照片到具有修改名称的文件对话框路径

2 个答案: