Sub GenerateColorVariations2024()
Dim baseC As Integer, baseM As Integer, baseY As Integer, baseK As Integer
Dim rangeVal As Integer, stepVal As Integer
Dim doc As Document
Dim s As Shape, textObj As Shape
Dim iC As Integer, iM As Integer, iY As Integer, iK As Integer
Dim x As Double, y As Double
Dim count As Integer
Dim startX As Double, startY As Double
Dim patchSize As Double, margin As Double
Dim outputPath As String
' ===== НАСТРОЙКИ =====
' Используем миллиметры для более предсказуемых результатов
startX = -100 ' Начинаем левее центра
startY = 100 ' Начинаем выше центра
patchSize = 15
margin = 5
outputPath = "C:\Corel_Color_Variations.pdf"
' ===== ВВОД ПАРАМЕТРОВ =====
baseC = Val(InputBox("Cyan (0-100):", "Базовый цвет", "50"))
If baseC < 0 Then Exit Sub ' Пользователь нажал Cancel
baseM = Val(InputBox("Magenta (0-100):", "Базовый цвет", "100"))
If baseM < 0 Then Exit Sub
baseY = Val(InputBox("Yellow (0-100):", "Базовый цвет", "0"))
If baseY < 0 Then Exit Sub
baseK = Val(InputBox("Black (0-100):", "Базовый цвет", "0"))
If baseK < 0 Then Exit Sub
rangeVal = Val(InputBox("Диапазон (±%):", "Настройки", "10"))
If rangeVal <= 0 Then Exit Sub
stepVal = Val(InputBox("Шаг (%):", "Настройки", "5"))
If stepVal <= 0 Then Exit Sub
' ===== ПРОВЕРКА ВВОДА =====
If baseC < 0 Or baseC > 100 Or baseM < 0 Or baseM > 100 Or _
baseY < 0 Or baseY > 100 Or baseK < 0 Or baseK > 100 Then
MsgBox "Значения CMYK должны быть от 0 до 100%", vbCritical
Exit Sub
End If
If rangeVal > 100 Or stepVal > 100 Then
MsgBox "Диапазон и шаг не должны превышать 100%", vbCritical
Exit Sub
End If
' ===== ИНИЦИАЛИЗАЦИЯ =====
Set doc = Application.ActiveDocument
If doc Is Nothing Then
MsgBox "Откройте документ в CorelDRAW!", vbCritical
Exit Sub
End If
' Устанавливаем единицы измерения в миллиметры
doc.Unit = cdrMillimeter
' Очистка страницы (более безопасный способ)
On Error Resume Next
If doc.ActivePage.Shapes.Count > 0 Then
doc.ActivePage.Shapes.All.Delete
End If
On Error GoTo 0
' ===== СОЗДАНИЕ ПАТЧЕЙ =====
count = 0
Dim maxPerRow As Integer: maxPerRow = 10
Dim totalPatches As Integer
' Подсчитываем общее количество патчей
totalPatches = ((2 * rangeVal) \ stepVal + 1) ^ 4
If totalPatches > 1000 Then
If MsgBox("Будет создано " & totalPatches & " патчей. Это может занять много времени. Продолжить?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If
End If
' Создаем патчи
For iC = -rangeVal To rangeVal Step stepVal
For iM = -rangeVal To rangeVal Step stepVal
For iY = -rangeVal To rangeVal Step stepVal
For iK = -rangeVal To rangeVal Step stepVal
' Коррекция значений
Dim cVal As Integer, mVal As Integer, yVal As Integer, kVal As Integer
cVal = LimitValue(baseC + iC, 0, 100)
mVal = LimitValue(baseM + iM, 0, 100)
yVal = LimitValue(baseY + iY, 0, 100)
kVal = LimitValue(baseK + iK, 0, 100)
' Позиция (исправленная система координат)
x = startX + (count Mod maxPerRow) * (patchSize + margin)
y = startY - (count \ maxPerRow) * (patchSize + margin)
' Создание патча
Set s = doc.ActiveLayer.CreateRectangle(x, y, x + patchSize, y - patchSize)
' Применяем заливку
s.Fill.ApplyUniformFill CreateCMYKColor(cVal, mVal, yVal, kVal)
' Настройка контура
s.Outline.Width = 0.1
s.Outline.Color.CMYKAssign 0, 0, 0, 100
' Подпись (исправленное создание и позиционирование текста)
If stepVal <= 10 Then ' Показываем текст только при крупном шаге
Dim labelText As String
labelText = "C" & cVal & " M" & mVal & Chr(13) & "Y" & yVal & " K" & kVal
Set textObj = doc.ActiveLayer.CreateArtisticText(x, y - patchSize - 3, labelText)
' Исправленное форматирование текста
On Error Resume Next
With textObj.Text
.Size = 6
.Font = "Arial"
End With
textObj.Text.Story.Font = "Arial"
textObj.Text.Story.Size = 6
On Error GoTo 0
' Цвет текста
textObj.Fill.ApplyUniformFill CreateCMYKColor(0, 0, 0, 100)
End If
count = count + 1
' Обновляем экран каждые 50 патчей
If count Mod 50 = 0 Then
Application.Refresh
DoEvents
End If
Next iK
Next iY
Next iM
Next iC
' ===== ФИНАЛИЗАЦИЯ =====
' Обновляем документ
doc.ActivePage.GetBoundingBox
Application.Refresh
' ===== ЭКСПОРТ =====
On Error Resume Next
' Создаем структуру экспорта
Dim expFlt As ExportFilter
Set expFlt = doc.ExportEx(outputPath, cdrPDF)
If Err.Number = 0 Then
MsgBox "Успешно создано " & count & " цветовых патчей!" & vbCrLf & _
"Файл сохранен: " & outputPath, vbInformation, "Генерация завершена"
Else
MsgBox "Ошибка при экспорте: " & Err.Description & vbCrLf & _
"Патчи созданы в документе, но не экспортированы.", vbExclamation
End If
On Error GoTo 0
End Sub
Function CreateCMYKColor(C As Integer, M As Integer, Y As Integer, K As Integer) As Color
Dim clr As Color
Set clr = Application.CreateColor(cdrColorModelCMYK)
clr.CMYKAssign C, M, Y, K
Set CreateCMYKColor = clr
End Function
Function LimitValue(val As Integer, minVal As Integer, maxVal As Integer) As Integer
If val < minVal Then val = minVal
If val > maxVal Then val = maxVal
LimitValue = val
End Function
