Sub TileScanAndGroup()
Dim doc As Document
Dim page As Page
Dim bounds As Rect
Dim tileWidth As Double, tileHeight As Double ' Размеры прямоугольника (в пунктах)
Dim xStart As Double, xEnd As Double, yStart As Double, yEnd As Double
Dim xCurrent As Double, yCurrent As Double
Dim selectionRect As Rect
Dim shapesInTile As ShapeRange
Dim groupCount As Long
Dim feedbackRect As Shape ' Визуальный прямоугольник
' Настройки
tileWidth = 60 ' Ширина прямоугольника сканирования
tileHeight = 40 ' Высота прямоугольника сканирования
Const feedbackOpacity As Double = 0.2 ' Прозрачность визуальной сетки (0–1)
Set doc = ActiveDocument
Set page = doc.ActivePage
' Получаем границы страницы
Set bounds = page.GetBoundingBox
xStart = bounds.Left
xEnd = bounds.Right
yStart = bounds.Top
yEnd = bounds.Bottom
groupCount = 0
' Отключаем обновление экрана для скорости
doc.BeginCommandGroup
Application.RefreshScreen = False
' Сканируем сетку: слева направо, сверху вниз
yCurrent = yStart
Do While yCurrent > yEnd ' Y уменьшается сверху вниз
xCurrent = xStart
Do While xCurrent < xEnd ' X увеличивается слева направо
' Определяем прямоугольник для текущей ячейки сетки
Set selectionRect = New Rect
selectionRect.Left = xCurrent
selectionRect.Right = xCurrent + tileWidth
selectionRect.Top = yCurrent
selectionRect.Bottom = yCurrent - tileHeight
' Визуализируем прямоугольник (временный)
Set feedbackRect = page.CreateRectangle( _
selectionRect.Left, selectionRect.Top, _
selectionRect.Right, selectionRect.Bottom)
feedbackRect.Fill.UniformColor.RGBAssign 0, 255, 0 ' Зелёный цвет
feedbackRect.Opacity = feedbackOpacity
feedbackRect.Outline.Width = 0.1
' Находим объекты, пересекающие или содержащиеся в прямоугольнике
Set shapesInTile = page.FindShapes(selectionRect, cdrIntersectsRect Or cdrInsideRect)
' Если найдено 2+ объекта — группируем
If shapesInTile.Count >= 2 Then
shapesInTile.Group
groupCount = groupCount + 1
End If
' Удаляем визуальный прямоугольник
feedbackRect.Delete
' Переходим к следующему прямоугольнику по горизонтали
xCurrent = xCurrent + tileWidth
Loop
' Переходим к следующей строке по вертикали
yCurrent = yCurrent - tileHeight
Loop
' Включаем обновление экрана
Application.RefreshScreen = True
doc.EndCommandGroup
' Сообщение о результате
If groupCount > 0 Then
MsgBox "Сгруппировано " & groupCount & " прямоугольных областей.", vbInformation, "Готово"
Else
MsgBox "Не найдено областей с 2+ объектами для группировки.", vbExclamation, "Внимание"
End If
End Sub
