PowerPoint (全般) |
![]() ![]() |
(Windows 10 Home : PowerPoint 2016)
同じ大きさ、位置で重ね合わせるには
投稿日時: 18/12/05 00:27:49
投稿者: momo-k
|
---|---|
同種類の図や図形(グループ化も含む)のAとBを選択してある状態で
|
![]() |
投稿日時: 18/12/05 10:55:34
投稿者: sk
|
---|---|
引用: 引用: (標準モジュール) ----------------------------------------------------------------------- Sub EqualizeSelectedShapes() Dim pptShapeRange As PowerPoint.ShapeRange Dim pptFirstShape As PowerPoint.Shape Dim pptShape As PowerPoint.Shape Dim lngCnt As Long With Application.ActiveWindow.Selection If .Type <> ppSelectionShapes Then Exit Sub End If If .HasChildShapeRange Then Set pptShapeRange = .ChildShapeRange Else Set pptShapeRange = .ShapeRange End If End With If pptShapeRange.Count <= 1 Then Set pptShapeRange = Nothing Exit Sub End If Set pptFirstShape = pptShapeRange(1) For lngCnt = 2 To pptShapeRange.Count Set pptShape = pptShapeRange(lngCnt) If (pptShape.Type = pptFirstShape.Type) And _ (pptShape.AutoShapeType = pptFirstShape.AutoShapeType) Then pptShape.Rotation = pptFirstShape.Rotation pptShape.Width = pptFirstShape.Width pptShape.Height = pptFirstShape.Height pptShape.Top = pptFirstShape.Top pptShape.Left = pptFirstShape.Left End If Set pptShape = Nothing Next Set pptFirstShape = Nothing Set pptShapeRange = Nothing End Sub ----------------------------------------------------------------------- 以上のようなコードを実行なさればよろしいかと。 |
![]() |
投稿日時: 18/12/05 13:23:37
投稿者: momo-k
|
---|---|
返信いただき、まことに有難うございます
|
![]() |
投稿日時: 18/12/05 16:15:40
投稿者: sk
|
---|---|
引用: 「グループ化されてない単一の図形」と 「グループ化されている図形範囲」は 図形の種類として同じではないからです。 引用: 一方が「グループ化されている図形範囲」ならば その Shape オブジェクトの Type プロパティは 6( 定数 msoGroup と同じ値)を返すのに対し、 もう一方が「グループ化されていない単一の図形」ならば 6 以外の値(定数クラス MsoShapeType のうち、 定数 msoGroup を除いたいずれかのメンバと同じ値)を 返します。 引用: また、「グループ化されている図形範囲」を参照する Shape オブジェクトの AutoShapeType プロパティが どんな値を返すかは、そのグループがどのような オートシェイプの組み合わせによって構成されているか によって異なります。 例えば、「 3 つの楕円をグループ化した図形範囲」のように 全ての子オブジェクトのオートシェイプの種類が同じであるならば、 その AutoShapeType プロパティは -2 以外の値(定数クラス MsoAutoShapeType のうち、定数 msoShapeMixed を除いた いずれかのメンバと同じ値。楕円ならば 9 = msoShapeOval と同じ値)を返しますが、 「 1 つの四角形と 1 つの楕円をグループ化した図形範囲」のように 種類の異なる 2 つ以上のオートシェイプを子オブジェクトとする場合、 その AutoShapeType プロパティは -2(定数 msoShapeMixed と同じ値)を 返すことになります。 また「グループ化されてない単一の図形」が画像である場合、 その Type プロパティは 13(定数 msoPicture と同じ値)を、 AutoShapeType プロパティは 1(定数 msoShapeRectangle と同じ値)を 返します。 ・Type プロパティのみでは「オートシェイプの種類」による区別がつかない。 (四角形も楕円もプロック矢印も全て「オートシェイプ」である) ・AutoShapeType プロパティのみでは「図形の種類」による区別がつかない。 (「オートシェイプの四角形」と「画像」はどちらも「四角形」である) ・最初に選択されたのが「異なる種類のオートシェイプが グループ化された図形範囲」であるならば、 前述のコードの設定対象となるのは同じく ( Type プロパティと AutoShapeType プロパティが共に一致する) 「異なる種類のオートシェイプがグループ化された図形範囲」である。 (それぞれの子オブジェクトの種類が何であるかや、その個数とは無関係) ・最初に選択されたのが「同じ種類のオートシェイプが グループ化された図形範囲」であるならば、 前述のコードの設定対象となるのは 「それと同じ種類のオートシェイプがグループ化された図形範囲」である。 (それぞれのグループの子オブジェクトの個数とは無関係) 引用: 考え得る範囲選択のパターン、またはグループ化のパターンの それぞれにおいて、具体的にどうなさりたいか次第ではないでしょうか。 |
![]() |
投稿日時: 18/12/05 16:49:08
投稿者: momo-k
|
---|---|
返信いただき、ありがとうございます
|
![]() |
投稿日時: 18/12/05 17:13:49
投稿者: momo-k
|
---|---|
すみません、追記なのですが
|
![]() |
投稿日時: 18/12/05 17:50:04
投稿者: sk
|
---|---|
引用: 引用: (標準モジュール) ------------------------------------------------------------------- Sub EqualizeSelectedPictures() Dim pptShapeRange As PowerPoint.ShapeRange Dim pptFirstShape As PowerPoint.Shape Dim pptShape As PowerPoint.Shape Dim lngCnt As Long With Application.ActiveWindow.Selection If .Type <> ppSelectionShapes Then Exit Sub End If If .HasChildShapeRange Then Set pptShapeRange = .ChildShapeRange Else Set pptShapeRange = .ShapeRange End If End With If pptShapeRange.Count <= 1 Then Set pptShapeRange = Nothing Exit Sub End If Set pptFirstShape = pptShapeRange(1) If IsPicture(pptFirstShape) = False Then Set pptFirstShape = Nothing Set pptShapeRange = Nothing Exit Sub End If For lngCnt = 2 To pptShapeRange.Count Set pptShape = pptShapeRange(lngCnt) If IsPicture(pptShape) Then pptShape.LockAspectRatio = False pptShape.Rotation = pptFirstShape.Rotation pptShape.Width = pptFirstShape.Width pptShape.Height = pptFirstShape.Height pptShape.Top = pptFirstShape.Top pptShape.Left = pptFirstShape.Left End If Set pptShape = Nothing Next Set pptFirstShape = Nothing Set pptShapeRange = Nothing End Sub Function IsPicture(Shape As PowerPoint.Shape) As Boolean Dim pptChildShape As PowerPoint.Shape IsPicture = False If Shape Is Nothing Then Exit Function End If With Shape Select Case .Type Case msoPicture '何もしない Case msoGroup For Each pptChildShape In .GroupItems If pptChildShape.Type <> msoPicture Then Exit Function End If Next Case Else Exit Function End Select End With IsPicture = True End Function ------------------------------------------------------------------- こういうことでしょうか。 引用: 引用: 「最初に選択されたオブジェクト」以外のオブジェクトのサイズと位置を 「最初に選択されたオブジェクト」のそれに合わせろ、 ということではなく、 「最初に選択されたオブジェクト」のサイズと位置を 「 2 番目に選択されたオブジェクト」のそれに合わせろ、 ということでしょうか。 また、当初から A と B の 2 つのオブジェクトしか挙げられていませんが、 3 つ以上のオブジェクトが範囲選択されている場合のことは 想定されているのでしょうか。 |
![]() |
投稿日時: 18/12/05 18:25:44
投稿者: momo-k
|
---|---|
返信ありがとうございます
|
![]() |
投稿日時: 18/12/06 10:57:08
投稿者: sk
|
---|---|
引用: 引用: 引用: If pptShapeRange.Count <> 2 Then 引用: 引用: Set pptShape = pptShapeRange(2) If IsPicture(pptShape) Then pptFirstShape.LockAspectRatio = False pptFirstShape.Rotation = pptShape.Rotation pptFirstShape.Width = pptShape.Width pptFirstShape.Height = pptShape.Height pptFirstShape.Top = pptShape.Top pptFirstShape.Left = pptShape.Left End If Set pptShape = Nothing -------------------------------------------------------------- 以上のように書き換えてみて下さい。 |
![]() |
投稿日時: 18/12/06 12:47:04
投稿者: momo-k
|
---|---|
返信いただき、ありがとうございます
|