Програмная группировка графики

[Andru2008]

У меня не получается следующее:
1. Есть несколько программных блоков по созданию графических объектов с использованием группировки, например:
'Блок1:
With ActiveSheet.Shapes.BuildFreeform(ms oEditingAuto, 112.5, 141.75)
.AddNodes msoSegmentLine, msoEditingAuto, 207#, 85.5
.AddNodes msoSegmentLine, msoEditingAuto, 224.25, 150.75
.AddNodes msoSegmentLine, msoEditingAuto, 130.5, 176.25
.AddNodes msoSegmentLine, msoEditingAuto, 112.5, 141.75
.ConvertToShape.Select
End With
' Блок2:
With ActiveSheet.Shapes.BuildFreeform(ms oEditingAuto, 189.75, 408#)
.AddNodes msoSegmentCurve, msoEditingAuto, 266.25, 333#
.AddNodes msoSegmentCurve, msoEditingAuto, 213#, 283.5
.AddNodes msoSegmentCurve, msoEditingAuto, 189.75, 408#
.ConvertToShape.Select
End With
2. Таких блоков может быть произвольное количество и они могут описывать разные графические подэлементы.
3. Требуется объединить эти уже по отдельности сгруппированные объекты в один, но с сохранением уже созданных группировок (группировка второго уровня) - чтобы можно было применять локальные атрибуты к отдельным подэлементам (разный цвет, толщина линий и т.д). Это нужно сделать не методом выделения мышкой их на листе и ручной группировкой, а именно программно. При этом не требуется их искать на листе, а нужно всего лишь написать программу типа:
Блок1-N:
Блок1:
..............
End Блок1
Блок2:
..............
End Блок2
............
БлокN:
..............
End БлокN
End Блок1-N

Заранее спасибо за помощь.

[EducatedFool]

Sub test()
    ActiveSheet.Shapes.SelectAll: Selection.Delete
    Dim arr(): ReDim Preserve arr(1 To 1)
    
    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 112.5, 141.75)
        .AddNodes msoSegmentLine, msoEditingAuto, 207#, 85.5
        .AddNodes msoSegmentLine, msoEditingAuto, 224.25, 150.75
        .AddNodes msoSegmentLine, msoEditingAuto, 130.5, 176.25
        .AddNodes msoSegmentLine, msoEditingAuto, 112.5, 141.75
        ReDim Preserve arr(1 To UBound(arr) + 1): arr(UBound(arr) - 1) = .ConvertToShape.Name
    End With

    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 189.75, 408#)
        .AddNodes msoSegmentCurve, msoEditingAuto, 266.25, 333#
        .AddNodes msoSegmentCurve, msoEditingAuto, 213#, 283.5
        .AddNodes msoSegmentCurve, msoEditingAuto, 189.75, 408#
        ReDim Preserve arr(1 To UBound(arr) + 1): arr(UBound(arr) - 1) = .ConvertToShape.Name
    End With

    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 289.75, 108#)
        .AddNodes msoSegmentCurve, msoEditingAuto, 206.25, 133#
        .AddNodes msoSegmentCurve, msoEditingAuto, 223#, 183.5
        .AddNodes msoSegmentCurve, msoEditingAuto, 339.75, 108#
        ReDim Preserve arr(1 To UBound(arr) + 1): arr(UBound(arr) - 1) = .ConvertToShape.Name
    End With

    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 389.75, 308#)
        .AddNodes msoSegmentCurve, msoEditingAuto, 366.25, 533#
        .AddNodes msoSegmentCurve, msoEditingAuto, 313#, 383.5
        .AddNodes msoSegmentCurve, msoEditingAuto, 389.75, 308#
        ReDim Preserve arr(1 To UBound(arr) + 1): arr(UBound(arr) - 1) = .ConvertToShape.Name
    End With

    ReDim Preserve arr(1 To UBound(arr) - 1)
    ActiveSheet.Shapes.Range(arr).Group
End Sub

В массив arr записываются имена фигур.

Поскольку метод .ConvertToShape возвращает объект типа Shape, а выделять этот объект в принцепе не требуется, то я заменил все строки
.ConvertToShape.Select на строки ReDim Preserve arr(1 To UBound(arr) + 1): arr(UBound(arr) - 1) = .ConvertToShape.Name

[Andru2008]

Вот спасибо.
Попробую.

[Andru2008]

Еще раз спасибо за помощь.
Разобрался. Все работает. Точнее ПОЧТИ все работает.
Я так понял, что код:
ActiveSheet.Shapes.SelectAll: Selection.Delete
должен был бы выделять на листе все графические элементы уже ранее созданные и удалять их, но это не срабатывает - не выделяет и не удаляет.
сам участок кода: ActiveSheet.Shapes.SelectAll
я применяю в другом месте (в другой функции) он там у меня действительно выделяет все элементы (в вашем варианте он не работает вообще, хотя почему - не понимаю), но вот Selection.Delete
не работает - хоть убей (ни в вашем варианте, ни во всех моих попытках).
Почему это так?

[EducatedFool]

Я так понял, что код:
ActiveSheet.Shapes.SelectAll: Selection.Delete
должен был бы выделять на листе все графические элементы уже ранее созданные и удалять их

В Excel 2003 такой код работает нормально.
Попробуйте воспользоваться макрорекордером, если у Вас другая версия Excel. (выделите несколько фигур, и удалите их)

В моём случае макрорекордер пишет вот что:

Sub Макрос1()
    ActiveSheet.Shapes.Range(Array("Rectangle 1", "Oval 2", "Line 3")).Select
    Selection.Delete
End Sub

я применяю в другом месте (в другой функции) он там у меня действительно выделяет все элементы (в вашем варианте он не работает вообще, хотя почему - не понимаю)

Попробуйте избавиться от всех ссылок на ActiveSheet в коде.
Лучше всегда ссылаться на конкретный лист, потому что активным в процессе выполнения может стать любой лист (если макрос большой, можно и забыть, что где-то была команда активации другого листа)

Лучше использовать такую конструкцию:

Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Имя листа с фигурами")

sh.Shapes.SelectAll: Selection.Delete
With sh.Shapes
    ' ...
End With

Дополнительный плюс такого подхода - Excel формирует выпадающий список методов и свойств для объекта sh, в отличии от activesheet

[SAS888]

Вместо

ActiveSheet.Shapes.SelectAll

можно попробовать использовать

ActiveSheet.DrawingObjects.Select

[Andru2008]

Понимаете в чем хитрость:
1. Я открыл новую книгу и "тупо" взял весь предложенный во 2-м посту код и вставил в тело функции (без каких либо изменений) - все работает кроме ActiveSheet.Shapes.SelectAll: Selection.Delete

2. Я удивился и упростил эту функцию таким образом:

Function A() As Variant
  With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 112.5, 141.75)
        .AddNodes msoSegmentLine, msoEditingAuto, 207#, 85.5
        .AddNodes msoSegmentLine, msoEditingAuto, 224.25, 150.75
        .AddNodes msoSegmentLine, msoEditingAuto, 130.5, 176.25
        .AddNodes msoSegmentLine, msoEditingAuto, 112.5, 141.75
        A=.ConvertToShape.Name
    End With
    ActiveSheet.Shapes.SelectAll: Selection.Delete
End Function

И все работает, имя граф. элемента функция возвращает, группировка работает, даже О ЧУДО ActiveSheet.Shapes.SelectAll работает (для всех существующих элементов листа и только, что созданного), но Selection.Delete - не работает.

3. Я добавил еще одну функцию:

Function B () As Variant
   ActiveSheet.Shapes.SelectAll: Selection.Delete
End Function

Тоже самое - ActiveSheet.Shapes.SelectAll заработал (элемент созданный функцией А выделился), но Selection.Delete все равно не сработал.

Вопрос: Почему выделенный элемент (в функции В) все равно не удаляется при помощи Selection.Delete? Ведь он же выделился, но ....

Я просто дурею..... Тут уже вопрос не столько как можно иначе, сколько НУ ПОЧЕМУ ТАК?

[Andru2008]

Сообщение от EducatedFool

В моём случае макрорекордер пишет вот что:

Sub Макрос1()
    ActiveSheet.Shapes.Range(Array("Rectangle 1", "Oval 2", "Line 3")).Select
    Selection.Delete
End Sub

Так у меня он тоже самое пишет. И что главное - этот макрос СОЗДАННЫЙ "ЩЕЛКАНЬЕМ МЫШКОЙ" работает.

Ну а в функции (как мне надо - не макросом, а через вызов функции) - об особенностях этого я написал выше.

[Andru2008]

Сообщение от EducatedFool

Лучше использовать такую конструкцию:

Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets("Имя листа с фигурами")

sh.Shapes.SelectAll: Selection.Delete
With sh.Shapes
    ' ...
End With

Дополнительный плюс такого подхода - Excel формирует выпадающий список методов и свойств для объекта sh, в отличии от activesheet

Вставил этот код в функцию:

Function A() As Variant
 Dim sh As Worksheet
 Set sh = ThisWorkbook.Worksheets("1")
 sh.Shapes.SelectAll
 Selection.Delete
End Function

Смешно, но ранее созданную на листе графику он выделяет, но все равно не удаляет