Powerpoint VBA使复制形状视图处于活动状态以选择分组

Question

我的PowerPoint幻灯片上有8个图像库。根据用户表单输入，通过在原始图像名称后面添加“1”或“2”以使它们可区分，某些组件得到复制和重命名。然后，我想分组新图像（我正在构建组件图像中的项目）。我能够复制图像并将它们排列正确，但我在分组时遇到问题。请注意，我并不总是将相同数量的项目分组，而是依赖于用户输入。

我收到错误“Shape（unknown member）：无效的请求。要选择一个形状，它的视图必须是活动的。”

我搜索并试图从帮助论坛实施几个策略，但我是空的。

请帮助！ -Kevin

的下面的代码部分，因为它是很长，但是这是我的第一个问题就出现了：

Dim Cargo As Shape, Cargo_Dup as Shape, Chemical as Shape, Chemical_Dup as Shape 
Set Cargo = ActivePresentation.Slides(2).Shapes("Cargo") 
Set Chemical = ActivePresentation.Slides(2).Shapes("Chemical") 
Cargo.Name = "Cargo" 
Chemical.Name = "Chemical" 

With ActivePresentation 
Set Cargo_Dup = ActivePresentation.Slides(2).Shapes("Cargo") 
    With Cargo_Dup.Duplicate 
     .Name = "Cargo_1st" 
     .Left = 0 
     .Top = 540 
    End With 
'CHEMICAL 
If Input1 = "Chemical" Then 
    Set Chemical_Dup = ActivePresentation.Slides(2).Shapes("Chemical") 
     With Chemical_Dup.Duplicate 
      .Name = "Chemical" & 1 
      .Left = 36.74352 
      .Top = 540 + 0.36 
     End With 
    '''''WHERE PROBLEM ARISES''''' 
    ActivePresentation.Slides(2).Shapes("Cargo_1st").Select 
    ActivePresentation.Slides(2).Shapes("Chemical1").Select msoFalse 
    Set Vehicle = ActiveWindow.Selection.ShapeRange.Group 
    Vehicle.Name = "Vehicle" 
'Elseif with a bunch for options where addition grouping occurs 

Answer 1

我需要某种形式的键盘宏为我输入：

绝对不要选择任何东西，除非你绝对必须。 你几乎从不绝对必须。

您在问如何使视图处于活动状态，以便您可以选择某些内容。 我认为这是一个错误的问题。
知道如何使用形状而不必选择它们会更有用。 分组形状没有选择它们有点棘手，但它可以完成。

这里是你怎么可能去这样一个例子：

Sub GroupWithoutSelecting() 

    Dim oSl As Slide 
    Dim oSh As Shape 
    Dim aShapes() As String 

    Set oSl = ActivePresentation.Slides(2) ' or whichever slide you like 
    ReDim aShapes(1 To 1) 

    With oSl 
     For Each oSh In .Shapes 
      If oSh.Type <> msoPlaceholder Then ' can't group placeholders 

       ' Substitute the real condition you want to use 
       ' for selecting shapes to be grouped here 
       If oSh.Type = msoAutoShape Then 
        ' add it to the array 
        aShapes(UBound(aShapes)) = oSh.Name 
        ReDim Preserve aShapes(1 To UBound(aShapes) + 1) 
       End If 

      End If 
     Next 

     ' eliminate the last (empty) element in the array 
     ReDim Preserve aShapes(1 To UBound(aShapes) - 1) 

     ' Create a shaperange from the array members and group the shaperange 
     .Shapes.Range(aShapes).Group 

    End With ' oSl 

End Sub