mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Вывод списка фигур на листе Excel с их координатами

Данный макрос производит поиск фигур (графических объектов) на всех листах текущей книги 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

ВложениеРазмерЗагрузкиПоследняя загрузка
ShapesCoordinates.xls33.5 КБ604 дня 19 часов назад

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

А можно ли сделать гиперссылку на фигуру?

Игорь, а можно ли получать координаты фигур в таблице не относительно левого верхнего угла, а относительно новых осей ( скажем H1-H50 A20-Z20). И соответственно, координаты должны отображаться и отрицательными тоже, если они по другим сторонам осей. Я был бы благодарен за пример.

А как будет выглядеть макрос, если надо вывести информацию обо всех фигурах на листе? Для каждой фигуры в новую строку.

Вообще-то, удалить картинки можно одной строкой кода, - совсем необязательно их в цикле перебирать.
Мой макрос (как и сам Excel) не рассчитан на такое количество графических объектов на листе...

При большом числе объектов(попался в руки файл в котором их на листе было более 93 000, нужно было почистить) перебор коллекции не работает - рушится(на For Each sha In sh.Shapes) с общей ошибкой "automation error 80004005". Пришлось в цикле от .Count и вниз идти, так как при удалении Shape из коллекции индексы видимо пересчитываются, и при прямом проходе имеем выход за границы на (1/2 count + 1).

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
   __    ___    _____                        
/ _| / _ \ | ____| _ _ ___ __ _
| |_ | (_) | | _| | | | | / __| / _` |
| _| \__, | | |___ | |_| | | (__ | (_| |
|_| /_/ |_____| \__, | \___| \__, |
|___/ |___/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.