Всем привет!
Мне нужно создать Макрос в Coreldraw Для создания эффекта Halftone.
Чтобы я мог задавать максимальный и минимальный диаметр кружочков, их шаг и направление, например, квадратное, или под углом 60 градусов и т.д.
И чтобы на выходе я мог это сохранить в вектор. Например в DFX, SVG и т.д.
Исходное изображение может быть как растровым, так и векторным.
В конечном итоге должна получиться перфорация из кружочков разного размера.
И я написал вот немного кода, с помощью которого создается массив кружочков, потом каждый кружок проверяет цвет фона, на котором он расположен и в зависимости от интенсивности цвета он меняет свой размер.
И вроде бы рисует кружочки, но еще
нужно реализовать реальную логику получения яркости пикселя в CorelDRAW.
вот код
Sub CreateCirclesByBrightness()
Dim minDiameter As Double: minDiameter = 5
Dim maxDiameter As Double: maxDiameter = 15
Dim stepSize As Double: stepSize = 20
Dim circlesLayer As Layer
Dim bgLayer As Layer
Dim doc As Document
Dim x As Double, y As Double
Dim brightness As Double
Dim diameter As Double
Dim cir As Shape
Dim shp As Shape ' Переменная для перебора фигур
' Переменные для вычисления объединённых границ
Dim leftBoundary As Double, topBoundary As Double
Dim rightBoundary As Double, bottomBoundary As Double
Dim curLeft As Double, curTop As Double, curRight As Double, curBottom As Double
Dim firstShapeProcessed As Boolean
Dim lyr As Layer ' Переменная для перебора слоев
Set doc = ActiveDocument
' Поиск слоя Background на активной странице
Set bgLayer = Nothing
For Each lyr In ActivePage.Layers
If lyr.Name = "Background" Then
Set bgLayer = lyr
Exit For
End If
Next lyr
If bgLayer Is Nothing Then
MsgBox "Слой 'Background' не найден!", vbExclamation
Exit Sub
End If
' Поиск слоя Circles на активной странице
Set circlesLayer = Nothing
For Each lyr In ActivePage.Layers
If lyr.Name = "Circles" Then
Set circlesLayer = lyr
Exit For
End If
Next lyr
If circlesLayer Is Nothing Then
MsgBox "Слой 'Circles' не найден!", vbExclamation
Exit Sub
End If
' Удаляем все объекты на слое Circles
circlesLayer.Shapes.All.Delete
' Проверяем, есть ли фигуры на слое Background
If bgLayer.Shapes.Count = 0 Then
MsgBox "На слое Background нет фигур. Нечего анализировать.", vbExclamation
Exit Sub
End If
' Инициализируем флаг для первой фигуры
firstShapeProcessed = False
' Вычисляем объединённые границы всех фигур на слое Background вручную
For Each shp In bgLayer.Shapes
' Получаем границы текущей фигуры
shp.GetBoundingBox curLeft, curTop, curRight, curBottom
If Not firstShapeProcessed Then
' Для первой фигуры просто присваиваем значения
leftBoundary = curLeft
topBoundary = curTop
rightBoundary = curRight
bottomBoundary = curBottom
firstShapeProcessed = True
Else
' Для последующих фигур обновляем границы
If curLeft < leftBoundary Then leftBoundary = curLeft
If curTop < topBoundary Then topBoundary = curTop
If curRight > rightBoundary Then rightBoundary = curRight
If curBottom > bottomBoundary Then bottomBoundary = curBottom
End If
Next shp
' Проходим по области с шагом stepSize, используя вычисленные границы
For y = topBoundary To bottomBoundary Step stepSize
For x = leftBoundary To rightBoundary Step stepSize
' Анализ яркости под точкой (x, y)
brightness = GetBrightnessAtPoint(x, y, bgLayer)
' Вычисляем диаметр кружочка
diameter = minDiameter + (maxDiameter - minDiameter) * brightness
' Создаём кружок на слое Circles
Set cir = circlesLayer.CreateEllipse2(x, y, diameter / 2, diameter / 2)
cir.Fill.UniformColor.RGBAssign 128, 128, 128 ' Серый цвет
cir.Outline.SetNoOutline
Next x
Next y
End Sub
Function GetBrightnessAtPoint(x As Double, y As Double, layer As Layer) As Double
' !!! ВНИМАНИЕ: Это заглушка. Здесь нужно реализовать реальную логику
' !!! получения яркости пикселя в CorelDRAW.
' !!! Это может потребовать экспорта части изображения во временный Bitmap
' !!! и анализа пикселей через External API или другие методы.
' Возвращаем среднюю яркость для примера
GetBrightnessAtPoint = 0.5
End Function
Корел 2024
