シェイプグループ化 

シェイプグループ化

以下の通りすわ。

'#選択中のシェイプをグループ化
Sub selectRangeGroup()
    Selection.Group.Select
End Sub
'#選択中のシェイプをグループ解除
Sub selectRangeUngroup()
    Selection.Ungroup
End Sub
'#選択中の大枠内にあるシェイプをグループ化する。グループ完了時、囲みシェイプは削除する
Sub rangeGroupShape()
    'グループ化シェイプ名をカンマ区切りで保持する用
    Dim targetShapeName As String
    'カンマ区切りで保持したものを配列状態で保持するよう
    Dim targetShapeArray As Variant
    
    For Each shape In ActiveSheet.Shapes
        '条件参考:https://learn.microsoft.com/ja-jp/office/vba/api/office.msoshapetype
        If shape.Type = msoAutoShape Or shape.Type = msoGroup Or shape.Type = msoPicture Then
            '上辺、左辺、右辺、下辺が大枠内にあるシェイプのみを対象とする
            If Selection.left < shape.left _
                And Selection.top < shape.top _
                And shape.left + shape.width < Selection.left + Selection.width _
                And shape.top + shape.height < Selection.top + Selection.height Then
                'グループ対象シェイプの記録(後続処理でグループ化)
                targetShapeName = targetShapeName & shape.Name & ","
            End If
        End If
    Next
    '対象シェイプを囲っていたシェイプを削除する
    Selection.Delete
    'グループ対象シェイプ名を配列化
    targetShapeArray = Split(targetShapeName, ",")
    
    For Each shape In ActiveSheet.Shapes
        '全シェイプの中からグループ対象のものだけ選択状態にする
        If isExistArray(targetShapeArray, shape.Name) Then
            shape.Select Replace:=False
        End If
    Next
    
    On Error GoTo catch
    
    If VarType(Selection) = vbObject Then
        '選択中シェイプをグループ化
        Selection.Group.Select
    End If
    
    Exit Sub
catch:
End Sub

配列内チェックは別記事にあるけど、ここは配列要素がない場合、Falseを返すようにしてるから以下のソースを使うといい。

'#配列内に存在するかどうか
Function isExistArray(targetArray As Variant, checkValue As String)
    isExistArray = False
    
    If UBound(targetArray) = -1 Then
        'UBoundの戻り値:-1は要素数0を示す。この場合、すべて対象外とする
        isExistArray = False
        Exit Function
    End If
    
    For i = LBound(targetArray) To UBound(targetArray)
        If targetArray(i) = checkValue Then
            isExistArray = True
            Exit For
        End If
    Next
End Function


コメント