PowerPoint (全般)

PowerPoint 全般に関する話題を扱うフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Home : PowerPoint 2016)
同じ大きさ、位置で重ね合わせるには
投稿日時: 18/12/05 00:27:49
投稿者: momo-k

同種類の図や図形(グループ化も含む)のAとBを選択してある状態で
@Aを基準にBを同じ大きさ(縦、横、角度)に
ABをAと同じ位置に重ね合わせる
この@とAを実行させるにはどのようなコードになるか
ご存知の方がおられましたら、教えてください
    
なお、一番最初に選択してあるものをA、次いでBとし
1つ以下もしくは何も選択されていない場合はキャンセルとしていただきたいです

回答
投稿日時: 18/12/05 10:55:34
投稿者: sk

引用:
同種類の図や図形(グループ化も含む)のAとBを選択してある状態で
@Aを基準にBを同じ大きさ(縦、横、角度)に
ABをAと同じ位置に重ね合わせる

引用:
なお、一番最初に選択してあるものをA、次いでBとし
1つ以下もしくは何も選択されていない場合はキャンセル

(標準モジュール)
-----------------------------------------------------------------------
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

返信いただき、まことに有難うございます
sk様からいただきましたコードを試してみたところ
ほぼ問題なく、同じ大きさと位置で重ね合わせることができました
 
ただ一つだけ
Aは図や図形、Bはグループ化されている図や図形の場合(またはその逆)
はコードが実行されないのですが、この場合どうしたらよろしいでしょうか
 
不勉強で申し訳ありませんがよろしくお願いします

回答
投稿日時: 18/12/05 16:15:40
投稿者: sk

引用:
Aは図や図形Bはグループ化されている図や図形の場合(またはその逆)
はコードが実行されないのですが

「グループ化されてない単一の図形」と
「グループ化されている図形範囲」は
図形の種類として同じではないからです。
 
引用:
pptShape.Type = pptFirstShape.Type

一方が「グループ化されている図形範囲」ならば
その Shape オブジェクトの Type プロパティは
6( 定数 msoGroup と同じ値)を返すのに対し、
もう一方が「グループ化されていない単一の図形」ならば
6 以外の値(定数クラス MsoShapeType のうち、
定数 msoGroup を除いたいずれかのメンバと同じ値)を
返します。
 
引用:
pptShape.AutoShapeType = pptFirstShape.AutoShapeType

また、「グループ化されている図形範囲」を参照する
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

返信いただき、ありがとうございます
なかなか自分には理解が追いつかず、申し訳ないです
少し変えてみたのですが、これではどうでしょうか
 
@A、Bともに単一の画像
AAは単一の画像、Bはグループ化された画像(子オブジェクトもすべて画像)
BAはグループ化された画像(子オブジェクトもすべて画像)、Bは単一の画像
CA、Bともにグループ化された画像(子オブジェクトもすべて画像)
 
上記4つに当てはまるものはAを基準に同じ大きさと位置で重ね合わせる
そうでないものはキャンセルとする
 

投稿日時: 18/12/05 17:13:49
投稿者: momo-k

すみません、追記なのですが
はじめに記載いたしました
一番最初に選択してあるものをA、次いでBとし〜」を
一番最初に選択してあるものをB、次いでAとし〜」に変更してください

回答
投稿日時: 18/12/05 17:50:04
投稿者: sk

引用:
@A、Bともに単一の画像
AAは単一の画像、Bはグループ化された画像(子オブジェクトもすべて画像
BAはグループ化された画像(子オブジェクトもすべて画像)、Bは単一の画像
CA、Bともにグループ化された画像(子オブジェクトもすべて画像

引用:
上記4つに当てはまるものはAを基準に同じ大きさと位置で重ね合わせる
そうでないものはキャンセルとする

(標準モジュール)
-------------------------------------------------------------------
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
-------------------------------------------------------------------
 
こういうことでしょうか。
 
引用:
@Aを基準にBを同じ大きさ(縦、横、角度)に
ABをAと同じ位置に重ね合わせる

引用:
はじめに記載いたしました
「一番最初に選択してあるものをA、次いでBとし〜」を
一番最初に選択してあるものをB、次いでAとし〜」に変更してください

「最初に選択されたオブジェクト」以外のオブジェクトのサイズと位置を
「最初に選択されたオブジェクト」のそれに合わせろ、
ということではなく、
「最初に選択されたオブジェクト」サイズと位置を
「 2 番目に選択されたオブジェクト」のそれに合わせろ、
ということでしょうか。
 
また、当初から A と B の 2 つのオブジェクトしか挙げられていませんが、
3 つ以上のオブジェクトが範囲選択されている場合のことは
想定されているのでしょうか。

投稿日時: 18/12/05 18:25:44
投稿者: momo-k

返信ありがとうございます
  
大変失礼しました。sk様がおっしゃるとおり、
「最初に選択されたオブジェクト」のサイズと位置を
「 2 番目に選択されたオブジェクト」のそれに合わせる

ということでお願いします
  
また3 つ以上のオブジェクトが範囲選択されている場合
キャンセルとしていただきたいです

回答
投稿日時: 18/12/06 10:57:08
投稿者: sk

引用:
1つ以下もしくは何も選択されていない場合はキャンセル

引用:
3 つ以上のオブジェクトが範囲選択されている場合は
キャンセル

引用:
If pptShapeRange.Count <= 1 Then

If pptShapeRange.Count <> 2 Then
 
引用:
「最初に選択されたオブジェクト」のサイズと位置を
「 2 番目に選択されたオブジェクト」のそれに合わせる

引用:
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 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

返信いただき、ありがとうございます
 
sk様からのアドバイスならびにコードを試したところ
問題なくサイズ、位置を重ね合わせることができました
 
とにもかくにもかぎられた時間の中で効率よく作業しなくてはならず
いろいろ参考になるものを探してはいたのですが見つからず困り果てておりました
 
無知な私に長いお時間、お付き合いくださいまして感謝申し上げます