Данный макрос производит поиск фигур (графических объектов) на всех листах текущей книги Excel,
и выводит следующую информацию по каждой найденной фигуре:
- Название фигуры (графического объекта)
- Координаты верхнего левого угла
- Координаты правого нижнего угла
- Размеры фигуры (ширина, высота)
- Тип фигуры (свойство Type типа MsoShapeType)
- Тип автофигуры (свойство AutoShapeType типа MsoAutoShapeType)
Вывод информации производится в окно Immediate
Sub ВыводСпискаАвтофигурСКоординатами() Dim sh As Worksheet, sha As Shape For Each sh In ThisWorkbook.Worksheets Debug.Print "=== Лист «" & sh.Name & "» - количество фигур: " & sh.Shapes.Count & " ===" For Each sha In sh.Shapes n = n + 1: Debug.Print " Фигура №" & n & " с названием «" & sha.Name & "»" Debug.Print " Координаты верхнего левого угла: X=" & sha.Left & "; Y=" & sha.Top Debug.Print " Координаты правого нижнего угла: X=" & sha.Left + sha.Width & "; Y=" & sha.Top + sha.Height Debug.Print " Размеры фигуры: ширина=" & sha.Width & "; высота=" & sha.Height Debug.Print " Тип фигуры: " & sha.Type & "; тип автофигуры: " & sha.AutoShapeType Next sha Debug.Print "=== Конец просмотра листа «" & sh.Name & "» ===" & vbNewLine Next sh End Sub
В прикреплённом файле нажмите кнопку «Запуск» для запуска макроса
Результат работы макроса:
=== Лист «Лист1» - количество фигур: 4 ===
Фигура №1 с названием «КнопкаЗапуска»
Координаты верхнего левого угла: X=48; Y=25,5
Координаты правого нижнего угла: X=144; Y=51
Размеры фигуры: ширина=96; высота=25,5
Тип фигуры: 1; тип автофигуры: 5
Фигура №2 с названием «AutoShape 2»
Координаты верхнего левого угла: X=105; Y=121,5
Координаты правого нижнего угла: X=216; Y=213,75
Размеры фигуры: ширина=111; высота=92,25
Тип фигуры: 1; тип автофигуры: 89
Фигура №3 с названием «Солнце»
Координаты верхнего левого угла: X=255; Y=49,5
Координаты правого нижнего угла: X=315,75; Y=107,25
Размеры фигуры: ширина=60,75; высота=57,75
Тип фигуры: 1; тип автофигуры: 23
Фигура №4 с названием «Oval 4»
Координаты верхнего левого угла: X=341,25; Y=154,5
Координаты правого нижнего угла: X=459; Y=197,25
Размеры фигуры: ширина=117,75; высота=42,75
Тип фигуры: 1; тип автофигуры: 9
=== Конец просмотра листа «Лист1» ===
=== Лист «Лист2» - количество фигур: 2 ===
Фигура №5 с названием «WordArt 1»
Координаты верхнего левого угла: X=78,75; Y=27,75
Координаты правого нижнего угла: X=170,25; Y=120,75
Размеры фигуры: ширина=91,5; высота=93
Тип фигуры: 15; тип автофигуры: -2
Фигура №6 с названием «Стрелка»
Координаты верхнего левого угла: X=202,5; Y=81
Координаты правого нижнего угла: X=277,5; Y=188,25
Размеры фигуры: ширина=75; высота=107,25
Тип фигуры: 9; тип автофигуры: -2
=== Конец просмотра листа «Лист2» ===Скриншот результата: http://ExcelVBA.ru/pictures/20110925-5vf-80kb.jpg
А следующий код назначает всем автофигурам макрос с названием МакросДляФигуры:
Sub НазначениеОдногоМакросаВсемФигурам() Dim Sh As Worksheet, sha As Shape For Each Sh In ActiveWorkbook.Worksheets ' перебираем все листы в активной книге For Each sha In Sh.Shapes ' перебираем все фигуры на очередном листе ' назначаем макрос только тем фигурам, которым ещё не назначены макросы If sha.OnAction = "" Then sha.OnAction = "МакросДляФигуры" Next sha Next Sh End Sub
Назначенный макрос выводиn во вторую строку активного листа Excel информацию о выделенной фигуре: координаты, размеры, и название фигуры:
(см. пример в прикреплённом файле - пощелкайте на фигурах, кроме зеленой кнопки)
Sub МакросДляФигуры() On Error Resume Next ' получаем ссылку на фигуру, с которой был вызван этот макрос Dim sha As Shape: Set sha = ActiveSheet.Shapes(Application.Caller) ' заносим в диапазон ячеек a2:f2 координаты и размеры выделенной фигуры Range("a2:f2").Value = Array(sha.Left, sha.Top, _ sha.Left + sha.Width, sha.Top + sha.Height, _ sha.Width, sha.Height) sha.Select ' выделяем фигуру, которая запустила макрос End Sub
Комментарии
Для тех кто не понимает куда выводятся результаты работы макроса:
Нужно нажать комбинацию Ctrl+G для отображения окна Immediate или через меню View > Immediate Window
А можно ли сделать гиперссылку на фигуру?
Игорь, а можно ли получать координаты фигур в таблице не относительно левого верхнего угла, а относительно новых осей ( скажем H1-H50 A20-Z20). И соответственно, координаты должны отображаться и отрицательными тоже, если они по другим сторонам осей. Я был бы благодарен за пример.
А как будет выглядеть макрос, если надо вывести информацию обо всех фигурах на листе? Для каждой фигуры в новую строку.
Вообще-то, удалить картинки можно одной строкой кода, - совсем необязательно их в цикле перебирать.
Мой макрос (как и сам Excel) не рассчитан на такое количество графических объектов на листе...
При большом числе объектов(попался в руки файл в котором их на листе было более 93 000, нужно было почистить) перебор коллекции не работает - рушится(на For Each sha In sh.Shapes) с общей ошибкой "automation error 80004005". Пришлось в цикле от .Count и вниз идти, так как при удалении Shape из коллекции индексы видимо пересчитываются, и при прямом проходе имеем выход за границы на (1/2 count + 1).
Отправить комментарий