CorelScript. БАЗОВЫЕ СКРИПТЫ

Документация по командам:  DRAW11VBA.HLP (Program files -> Corel -> CorelGraphics -> Programs)

Содержание

Построение отрезка
Отрезок строится еще проще
Построение эллпса/окружности  и заливка его зеленым цветом*
Построение эллпса/окружности - 2-й способ
Построение прямоугольника и заливка его красным цветом*
Построение многоугольника*
Построение ломаной линии
Построение ломаной линии в CorelDraw 11
Задание полигона:
    квадрата
    прозвольного полигона
Построение кривой Безье
Многоугольники (звезды)
Вывод сообщений  на печать
Вывод значений  на печать
Добавить страницу
Задать странице цвет
Вставить из Clipboard-а
Вставить текст на лист (английский)
Увеличение
Вращение: рисуем подсолнух
The following example exports the new document to JPEG.
Расставить точки (удачно можно применить в оформлении чертежей НГ)
МК задает эллипс в мм
Залить ранее созданную замкнутую полилинию красным цветом
Преобразовать две фигуры в кривые объединить сдвинуть и залить их цветом
Спираль
Кривая
Задание кривой Безье и отрезки на концах
Эффекты: чудеса с заливкой
Еще один эффект (сильный)
Преобразование контура эллипса в ломаную линию
Эффекты с текстом
Задание кривой
Вычисления для активной кривой
Взять у кривой 1-й сегмент и сдвинуть
Преобразовать сегменты полигона в кривые
 Преобразовать сегменты кривой в прямые
 Добавить в сегмент кривой точку
Вычисление длины кривой в дюймах
Преобразовать ломаную линию в гладкую кривую
Преобразовать активной ломаной в кривую
Получить информацию о кривой
Добавить объект в контейнер
Эллипс конвертировать в ромб
Перебрать точки на окружности
Залить активную группу
Автоматически у окружности (стей) отсекает четверть
Растяжка в прямоугольнике цвета от красного до золота
Чертит рамку вокруг формы
Преобразовать мноугольник с одним числом сторон в другой
Вращение эллипса со случайной  заливкой цветом
МК ставит точки на кривой
Двигать случайным образом
Добавить в контейнер
Клонировать
Комбиноровать в новом документе
Рисовать с тенью
Последовательное преобразование одного эллипса в другой
МК рисует магический глаз
Шахматы по сторонам куба
Удалить активный объект
МК рисует полумесяц
МК определяет центр полилинии
Группирует
Сложение цветов
Передвинуть на шаг вперед
Вытащить из контейнера
Вращение
МК рисует куб в изометрии
МК рисует арку
Масштаб и сдвинуть
Сделать полигон (crvs673) активным и залить цветом


Документация по командам см:  DRAW11VBA.HLP (Draw -> Programs)
 

Построение отрезка

Sub Macro1()
x1 = 2.388236
y1 = 6.269638
x2 = 5.42985
y2 = 8.279748
    Dim s5 As Shape
    Set s5 = ActiveLayer.CreateCurve
    With s5.Curve.CreateSubPath(x1, y1)
        .AppendLineSegment False, x2, y2
    End With
End Sub
 

Отрезок еще проще

Sub Test()
    Dim s As Shape
    Set s = ActiveLayer.CreateLineSegment(0, 0, 4, 4)
End Sub
 


Построение эллпса/окружности  и заливка его зеленым цветом*

Sub Macro2()
    x1 = 4.76863
    y1 = 8.597134
    x2 = 4.239654
    y2 = 8.068157
    Dim s51 As Shape
    Set s51 = ActiveLayer.CreateEllipse(x1, y1, x2, y2, 90#, 90#, False)
    s51.Fill.UniformColor.CMYKAssign 100, 0, 100, 0   ' зеленый
End Sub

где  x1,y1,x2,y2 - координаты противоположных вершин прямоугольника вокруг эллипса

Или эллипс можно строить так:
Sub Macro()
    ActiveLayer.CreateEllipse 3, 3, 2, 1
End Sub


Построение прямоугольника и заливка его красным цветом*

Sub Macro3()
    x1 = 3.639421
    y1 = 6.502878
    x2 = 6.291913
    y2 = 3.688402
    Dim s237 As Shape
    Set s237 = ActiveLayer.CreateRectangle(x1, y1, x2, y2, 0, 0, 0, 0)
    s237.Fill.UniformColor.CMYKAssign 0, 100, 100, 0  ' красный
End Sub

Построение многоугольника*

Sub Macro3()
    x1 = 5.165362
    y1 = 10.131165
    x2 = 0.880654
    y2 = 5.079441
    n = 6
    nf = 2
    Dim s583 As Shape
    Set s583 = ActiveLayer.CreatePolygon(x1, y1, x2, y2, n, nf, 1, False, 50, 100)
    s583.Fill.UniformColor.CMYKAssign 0, 100, 100, 0
End Sub

Где:
где  x1,y1,x2,y2 - координаты противоположных вершин прямоугольника вокруг многоугольника
n - число сторон
nf- параметр форм (2 - треугольники на сторонах снаружи, 3 - просто отрезки)


Построение ломаной линии

Можно модернизировать прямую - добавив в нее вручную  дополнительные точки (добавить для каждой точки одну строку). Вот пример задания прямоугольного треугольника.

Sub Macro1()
    x1 = 3
    y1 = 5
    x2 = 3
    y2 = 9
    x3 = 7
    y3 = 5
 
    Dim s1655 As Shape
    Set s1655 = ActiveLayer.CreateCurve
    With s1655.Curve.CreateSubPath(x1, y1)
        .AppendLineSegment False, x2, y2
        .AppendLineSegment False, x3, y3
        .AppendLineSegment False, x1, y1
    End With
End Sub
Примечание. К сожалению треугольник залить цветом нет возможности. Как строить полигон   из отрезков тоже пока не найдено возможности (надо читать документацию!!!!!)


Построение полигона квадрата в МК вручную

Sub Macro1()
    a = 2  ' сторона квадрата
    xc = 4  '  точка привязки
    yc = 4
 
    Dim s644 As Shape
    Dim crvs644 As Curve
    Set crvs644 = CreateCurve(ActiveDocument)
    With crvs644.CreateSubPath(xc, yc)
        .AppendLineSegment xc + a, yc
        .AppendLineSegment xc + a, yc + a
        .AppendLineSegment xc, yc + a
        .AppendLineSegment xc, yc
        .Closed = True
    End With
    Set s644 = ActiveLayer.CreateCurve(crvs644)
    s644.Fill.UniformColor.CMYKAssign 0, 100, 0, 0
 
End Sub

Задание произвольного полигона в МК вручную

Sub Macro2()
    x1 = 2
    y1 = 2
    x2 = 4
    y2 = 2
    x3 = 4
    y3 = 4
    x4 = 2
    y4 = 4
 
 
    Dim s644 As Shape
    Dim crvs644 As Curve
    Set crvs644 = CreateCurve(ActiveDocument)
    With crvs644.CreateSubPath(x1, y1)
        .AppendLineSegment x2, y2
        .AppendLineSegment x3, y3
        .AppendLineSegment x4, y4
        .AppendLineSegment x1, y1
        .Closed = True
    End With
    Set s644 = ActiveLayer.CreateCurve(crvs644)
    s644.Fill.UniformColor.CMYKAssign 0, 100, 0, 0
 
End Sub
 



Построение ломаной линии в CorelDraw 11
Строим прямоугольник:

Sub Macro1()
    x1 = 0
    y1 = 0
    x2 = 5
    y2 = 0
    x3 = 5
    y3 = 5
    x4 = 0
    y4 = 5
    Dim s1279 As Shape
    Dim crvs1279 As Curve
    Set crvs1279 = CreateCurve(ActiveDocument)
    With crvs1279.CreateSubPath(x1, y1)
        .AppendLineSegment x2, y2
        .AppendLineSegment x3, y3
        .AppendLineSegment x4, y4
        .AppendLineSegment x1, y1
    End With
    Set s1279 = ActiveLayer.CreateCurve(crvs1279)
End Sub


Построение кривой Безье

Sub Macro2()
    x1 = 1
    y1 = 2
    x2 = 7
    y2 = 2
    x3 = 2
    y3 = 100
    x4 = 7
    y4 = 25
    Dim s1677 As Shape
    Set s1677 = ActiveLayer.CreateCurve
    With s1677.Curve.CreateSubPath(x1, y1)
        .AppendCurveSegment False, x2, y2, x3, y3, x4, y4
    End With
End Sub
 x1,  y1,   x2,   y2 - начало и конец кривой
 x3,  y3,   x4,   y2 - вектора начало и конца кривой.

Многоугольники (звезды)

Sub Macro4()
   n = 5  ' число вершин
    Dim s1477 As Shape
 Set s1477 = ActiveLayer.CreatePolygon(6.514535, 9.112594, 0.891512, 4.03248, n, 1, 1, True, 50, 100)
    s1477.ConvertToCurves
End Sub


Вывод сообщений  на печать

Sub Test2()
 
        MsgBox "Select a connector line"
 
End Sub

Вывод значений  на экран

Sub Makro6()
    x = 10
        MsgBox "x = " & x
 
End Sub
 


Добавить страницу

Sub DocumentActive()
 CreateDocument
 ActiveLayer.CreateEllipse2 3, 2, 1
 CreateDocument
 ActiveLayer.CreateRectangle 2, 3, 4, 5
 Documents(1).Activate
 ActiveDocument.AddPages 1
End Sub

Задать странице цвет

Sub PageActive()
    ActivePage.Color.RGBAssign 255, 0, 0
End Sub

Вставить из Clipboard-а

Sub ClipboardData()
 If Not Clipboard.Empty Then
  ActiveLayer.Paste
 Else
  MsgBox "There is no data in the clipboard."
 End If
End Sub

Вставить текст на лист (английский)

Sub Text()
 ActiveLayer.CreateArtisticText 0, 0, "Text"
 ActiveDocument.ClearSelection
End Sub


Увеличение

Sub Test()
 Dim v As View
 Dim x As Double, y As Double
 x = ActivePage.SizeWidth / 2
 y = ActivePage.SizeHeight / 2
 Set v = ActiveDocument.CreateView("My New View", x, y, 200)
 v.Activate
End Sub


 Вращение: рисуем подсолнух

Sub Test()
 Const Leaves As Long = 30
 Const Radius As Double = 2
 Dim stp As Double
 Dim i As Long
 Dim d As Document
 Dim s As Shape
 stp = 360 / Leaves
 Set d = ActiveDocument
 d.DrawingOriginX = 0
 d.DrawingOriginY = 0
 d.BeginCommandGroup "Flower"
 Set s = d.ActiveLayer.CreateEllipse2(0, 0, Radius)
 s.Fill.UniformColor.RGBAssign 100, 50, 50
 Set s = d.ActiveLayer.CreateEllipse2(Radius + 0.5, 0, 0.5, 0.25)
 s.Fill.UniformColor.RGBAssign 255, 255, 0

s.RotationCenterX = 0
 s.RotationCenterY = 0
 d.ApplyToDuplicate = True
 For i = 1 To Leaves - 1
  s.Rotate i * stp
 Next i
 d.EndCommandGroup
End Sub


The following example exports the new document to JPEG.

Sub Test5()
    Dim d As Document
    Dim s As Shape
    Dim Filter As ExportFilter
    Set d = CreateDocument
    Set s = d.ActiveLayer.CreateEllipse2(4, 5, 2)
    s.Fill.ApplyFountainFill CreateRGBColor(255, 0, 0), CreateRGBColor(0, 0, 0)
    Set Filter = d.ExportBitmap("C:\Temp\Doc.jpeg", cdrJPEG, cdrCurrentPage, _
        cdrRGBColorImage, 0, 0, 72, 72)
    With Filter
        .Compression = 80
        .Optimized = True
        .Smoothing = 50
        .SubFormat = 1
        .Progressive = False

.Finish
    End With
End Sub


Расставить точки (удачно можно применить в оформлении чертежей НГ)

Sub Test()
 Dim x As Double, y As Double
 Dim Shift As Long
 Dim b As Boolean
 Dim s As Shape
 Dim cr As Long, cg As Long, cb As Long
 b = False
 While Not b
  b = ActiveDocument.GetUserClick(x, y, Shift, 10, False, cdrCursorEyeDrop)
  If Not b Then
   Set s = ActiveLayer.CreateEllipse(x - 0.1, y - 0.1, x + 0.1, y + 0.1)
   cr = 0
   cg = 0
   cb = 0
   If (Shift And 1) <> 0 Then cr = 255 ' Shift depressed - Add Red
   If (Shift And 2) <> 0 Then cg = 255 ' Ctrl depressed - Add Green

If (Shift And 4) <> 0 Then cb = 255 ' Alt depressed - Add Blue
   s.Fill.UniformColor.RGBAssign cr, cg, cb
  End If
 Wend
End Sub


МК задает эллипс в мм

Sub Test()
 With ActiveDocument
  .SaveSettings
  .ResetSettings
  .Unit = cdrMillimeter
  .DrawingOriginX = 0
  .DrawingOriginY = 0
  .ActiveLayer.CreateEllipse2 0, 0, 50
  .RestoreSettings
 End With
End Sub


Залить ранее созданную замкнутую полилинию красным цветом

Sub Test()

    Dim crv As Curve, s As Shape
    Set crv = CreateCurve(ActiveDocument)
    For Each s In ActivePage.Shapes
        crv.AppendCurve s.DisplayCurve
    Next s
    Set s = ActiveLayer.CreateCurve(crv)
    s.Fill.UniformColor.RGBAssign 255, 0, 0
End Sub


Преообразовать две фигуры в кривые объединить сдвинуть и залить их цветом

Sub Test()
 Dim s1 As Shape, s2 As Shape, sCurve As Shape
 Dim c As Curve
 Set s1 = ActiveDocument.ActiveLayer.CreateEllipse2(4, 6.5, 0.5)
 Set s2 = ActiveDocument.ActiveLayer.CreateEllipse2(4, 5, 1)
 s1.Fill.ApplyUniformFill CreateRGBColor(255, 0, 0)
 s2.Fill.ApplyUniformFill CreateRGBColor(0, 0, 255)
 Set c = New Curve
 c.BindToDocument ActiveDocument
 c.AppendCurve s1.DisplayCurve
 c.AppendCurve s2.DisplayCurve
 Set sCurve = ActiveLayer.CreateCurve(c)

sCurve.Move 1, 1
 sCurve.Fill.ApplyUniformFill CreateRGBColor(0, 255, 0)
End Sub


Спираль

Sub Test()
 Dim c As Curve, n As Node, s As Shape
 Set s = ActiveLayer.CreateSpiral(4, 5, 7, 2, 8, cdrSymmetric, 2)
 Set c = s.Curve.GetCopy
 For Each n In c.Nodes
  n.Move Rnd(), Rnd() - 0.5
 Next n
 s.Curve.CopyAssign c
End Sub

' (c) 2002 Corel Corporation. All rights reserved.


Кривая

Example

The following example creates a new curve object in the active document. There are two line segments and three curve segments within the subpath.

Sub Test()
 Dim s As Shape
 Dim sp As SubPath
 Dim crv As Curve
 Set crv = CreateCurve(ActiveDocument)
 ActiveDocument.ReferencePoint = cdrBottomLeft
 Set sp = crv.CreateSubPath(1, 1)
 ' sp.AppendLineSegment 1, 1
 sp.AppendCurveSegment 3, 3
 sp.AppendCurveSegment 5, 1
 sp.AppendCurveSegment 7, 4
 sp.AppendLineSegment 9, 0
 sp.Nodes(2).Type = cdrSmoothNode
 sp.Nodes(3).Type = cdrSmoothNode
 sp.Nodes(4).Type = cdrSmoothNode
 sp.Nodes(5).Type = cdrSmoothNode

Set s = ActiveLayer.CreateCurve(crv)
End Sub
Примечание: Убрав  sp.Nodes (4 строки) - получим ломаную линию


Задание кривой Безье и отрезки на концах

Sub Test()
 Dim ce(5) As CurveElement
 Dim crv As Curve
 ce(0).ElementType = cdrElementStart
 ce(0).PositionX = 0
 ce(0).PositionY = 0
 ce(1).ElementType = cdrElementLine
 ce(1).NodeType = cdrSmoothNode
 ce(1).PositionX = 1
 ce(1).PositionY = 1
 ce(2).ElementType = cdrElementControl
 ce(2).PositionX = 2
 ce(2).PositionY = 2
 ce(3).ElementType = cdrElementControl
 ce(3).PositionX = 3
 ce(3).PositionY = 2
 ce(4).ElementType = cdrElementCurve

ce(4).NodeType = cdrSmoothNode
 ce(4).PositionX = 4
 ce(4).PositionY = 1
 ce(5).ElementType = cdrElementLine
 ce(5).PositionX = 5
 ce(5).PositionY = 0
 Set crv = CreateCurve(ActiveDocument)
 crv.CreateSubPathFromArray ce
 ActiveLayer.CreateCurve crv
End Sub


Эффекты: чудеса с заливкой

The following example creates a contour with a color transition in the fountain fill.

Sub Test()
 Dim s As Shape
 Set s = ActiveLayer.CreateEllipse2(4.25, 5.5, 2)
 s.Fill.ApplyFountainFill CreateCMYKColor(100, 0, 0, 0), CreateCMYKColor(0, 0, 100, 0)
 s.Outline.SetProperties 0.02, , CreateCMYKColor(0, 0, 100, 0)
 With s.CreateContour(cdrContourOutside, 0.1, 20).Contour
  .FillColor.CMYKAssign 0, 0, 100, 0
  .FillColorTo.CMYKAssign 0, 100, 100, 0
  .OutlineColor.CMYKAssign 100, 0, 100, 0
 End With
End Sub


Еще один эффект (сильный)

Sub Test()
 Dim s As Shape, s2 As Shape
 Dim e As Effect
 Set s = ActiveLayer.CreateEllipse2(5, 4, 2)
 s.Fill.UniformColor.RGBAssign 255, 0, 0
 Set s2 = ActiveLayer.CreateRectangle(3, 3, 5, 5)
 s2.Fill.UniformColor.RGBAssign 0, 0, 255
 For Each s In ActiveLayer.Shapes.All
  Set e = s.CreateContour(cdrContourInside, , 5)
  e.Contour.ContourGroup.CreatePerspective 2, 2
 Next s
End Sub


Преобразование контура эллипса в ломаную линию

Sub Test()
 Dim s As Shape
 Set s = ActiveLayer.CreateEllipse2(1, 1, 1)
 With s.CreateZipperDistortion(0, 0, 10, 6).Distortion
  .OriginX = 1
  .OriginY = 0
 End With
End Sub

Эффекты с текстом

Sub Test()
 Dim s As Shape, eff As Effect
 Set s = ActiveLayer.CreateArtisticText(2.75, 5, "Text")
 With s.Text.FontProperties
  .Name = "Arial Black"
  .Size = 150
 End With
 Set eff = s.CreateEnvelope(1)
 eff.Envelope.Select 12
End Sub


Задание кривой

The following example creates a curve segment and adds a node at its center.

Sub Test()
 Dim s As Shape
 Set s = ActiveLayer.CreateCurveSegment(2, 8.3, 5.3, 8.5, 1.5, -62, 2.4, 84)
 s.Curve.Segments(1).AddNodeAt 0.5, cdrRelativeSegmentOffset
End Sub


Вычисления для активной кривой

The following example displays the distance of a point, with a parametric offset 0.5, from the beginning of the first segment of the active curve.

Sub Test()
 MsgBox ActiveShape.Curve.Segments(1).GetAbsoluteOffset(0.5)
End Sub


Взять у кривой 1-й сегмент и сдвинуть

Sub Test()
 Dim s As Shape, s2 As Shape
 Dim sp As SubPath
 Dim crv As Curve, crv2 As Curve
 
 Set crv = CreateCurve(ActiveDocument)
 ActiveDocument.ReferencePoint = cdrBottomLeft
 Set sp = crv.CreateSubPath(1, 1)
 sp.AppendLineSegment 1, 1
 sp.AppendCurveSegment 3, 3
 sp.AppendCurveSegment 5, 1
 sp.AppendCurveSegment 6, 4
 sp.AppendCurveSegment 8, 2
 sp.AppendLineSegment 10, 5
 sp.Nodes(2).Type = cdrSmoothNode
 sp.Nodes(3).Type = cdrSmoothNode

sp.Nodes(4).Type = cdrSymmetricalNode
 sp.Nodes(5).Type = cdrSmoothNode
 Set s = ActiveLayer.CreateCurve(crv)
 Set crv2 = s.Curve.Segments(2).GetCopy
 Set s2 = ActiveLayer.CreateCurve(crv2)
 s2.Move 0, 2
End Sub


Преобразовать сегменты полигона в кривые

 Sub Test()
 Dim s As Shape
 Dim seg As Segment
 Set s = ActiveLayer.CreatePolygon(3, 6, 7, 2, 3)
 s.ConvertToCurves
 s.Curve.Nodes.Range(2, 4, 6).Delete
 Set seg = s.Curve.Segments(2)
 seg.Previous.Type = cdrCurveSegment
 seg.Next.Type = cdrCurveSegment
 seg.Type = cdrCurveSegment
 seg.StartNode.Type = cdrSmoothNode
 seg.EndNode.Type = cdrSmoothNode
End Sub

 Преобразовать сегменты кривой в прямые

Example
The following example displays the number of curve segments in the selected curve. It then allows the user to convert all curve segments to lines.
 

Sub Test()
 Dim sgr As New SegmentRange
 Dim seg As Segment
 Dim r As VbMsgBoxResult
 If ActiveShape Is Nothing Then Exit Sub
 If ActiveShape.Type <> cdrCurveShape Then
  MsgBox "Select a curve and try again"
  Exit Sub
 End If
 For Each seg In ActiveShape.Curve.Segments
  If seg.Type = cdrCurveSegment Then sgr.Add seg
 Next seg
 If sgr.Count = 0 Then
  MsgBox "No curve segments found"
 Else
  r = MsgBox(sgr.Count & " curve segments found. Convert them to lines?", vbYesNo)

If r = vbYes Then
   sgr.SetType cdrLineSegment
  End If
 End If
End Sub


 Добавить в сегмент кривой точку

Sub Test()
 Dim sgr As SegmentRange
 Dim n As Node
 Dim i As Long
 Set sgr = ActiveShape.Curve.Segments.All
 For i = sgr.Count To 1 Step -1
  If sgr(i).Type = cdrLineSegment Then sgr.Remove i
  ' Same as: If sgr.Item(i).Type <> cdrLineSegment Then sgr.Remove i
 Next i
 If sgr.Count > 0 Then sgr.AddNode
End Sub


Вычисление длины кривой в дюймах

Sub Test()
 Dim sgr As New SegmentRange
 Dim seg As Segment
 For Each seg In ActiveShape.Curve.Segments
  If seg.Type = cdrCurveSegment Then sgr.Add seg
 Next seg
 MsgBox "All curve segments have total length of " & sgr.Length & """"
End Sub

Преобразовать ломаную линию в гладкую кривую

The following example converts all line segments to curves and changes the type of all ending nodes of the segments to smooth.
 

Sub Test()
 Dim sgr As New SegmentRange
 Dim seg As Segment
 For Each seg In ActiveShape.Curve.Segments
  If seg.Type = cdrLineSegment Then sgr.Add seg
 Next seg
 sgr.SetType cdrCurveSegment
 sgr.NodeRange.SetType cdrSmoothNode
End Sub


Преобразовать ломаную в гладкую кривую

The following example converts all segments in the selected shape to curve segments and changes the type of all its nodes to smooth.

Sub Test()
 With ActiveShape.Curve
  .Segments.All.SetType cdrCurveSegment
  .Nodes.All.SetType cdrSmoothNode
 End With
End Sub


Получить информацию о кривой

Sub Test()
    Dim crv As Curve
    Set crv = ActiveShape.Curve
    MsgBox "The curve contains:" & vbCr & _
        "Nodes: " & crv.Nodes.Count & vbCr & _
        "Segments: " & crv.Segments.Count & vbCr & _
        "Subpaths: " & crv.Subpaths.Count
End Sub

Добавить объект в контейнер

Sub Test()
 Dim rect As Shape, ell As Shape
 Set rect = ActiveLayer.CreateRectangle(0, 0, 4, 3)
 rect.Fill.UniformColor.RGBAssign 255, 0, 0
 Set ell = ActiveLayer.CreateEllipse(2, 1, 5, 4)
 ell.Fill.UniformColor.RGBAssign 255, 255, 0
 ell.AddToPowerClip rect
End Sub

Эллипс конвертировать в ромб

Sub Test()
 Dim s As Shape
 Set s = ActiveLayer.CreateEllipse2(3, 3, 2, 1)
 s.ConvertToCurves
 s.Curve.Segments.All.SetType cdrLineSegment
End Sub

Перебрать точки на окружности

Sub Test()
 Const Steps As Long = 50
 Dim s As Shape, sp As SubPath
 Dim x As Double, y As Double
 Dim t As Double
 Set s = ActiveLayer.CreateEllipse(0, 0, 5, 5)
 For Each sp In s.DisplayCurve.Subpaths
  For t = 0 To Steps - 1
   sp.GetPointPositionAt x, y, t / Steps
   ActiveLayer.CreateEllipse2 x, y, 0.05
  Next t
 Next sp
End Sub

Залить активную группу

Sub Test()
    Dim s1 As Shape, s2 As Shape, grp As Shape
    Set grp = ActiveSelection.Group
    With grp.Fill.ApplyPatternFill(cdrTwoColorPattern, "%%['$'UH$[UH", 0, _
              CreateCMYKColor(0, 100, 100, 0), CreateCMYKColor(0, 0, 100, 0), False)
.TransformWithShape = False
        .TileHeight = 1
        .TileWidth = 1
        .OriginX = 0
        .OriginY = 0
    End With
    grp.DrapeFill = True
End Sub

Автоматически у окружности (стей) отсекает четверть

Sub Test()
 Dim s As Shape
 For Each s In ActivePage.Shapes
  If s.Type = cdrEllipseShape Then
   With s.Ellipse
    .StartAngle = 0
    .EndAngle = 90
    .Clockwise = True
    .Type = cdrPie
   End With
  End If
 Next s
End Sub


Растяжка в парямоугольнике цвета от красного до золота

Sub Test()
 Dim s As Shape
 Set s = ActiveLayer.CreateRectangle(0, 0, 5, 5)
 s.Fill.ApplyFountainFill CreateRGBColor(255, 0, 0), CreateRGBColor(255, 255, 0)
End Sub


Чертит рамку вокруг формы

Sub Test()
 Const g2rad As Double = 1.74532925199433E-02
 Dim s As Shape, r As Shape
 Dim x As Double, y As Double
 Set s = ActiveShape
 If s Is Nothing Then
  MsgBox "Nothing selected. Please try again", vbCritical
  Exit Sub
 End If
 ActiveDocument.ReferencePoint = cdrCenter
 s.GetPosition x, y
 x = x - s.OriginalWidth / 2
 y = y - s.OriginalHeight / 2
 Set r = ActiveLayer.CreateRectangle2(x, y, s.OriginalWidth, s.OriginalHeight)
 r.Stretch s.AbsoluteHScale, s.AbsoluteVScale * Cos(s.AbsoluteSkew * g2rad)

r.Skew s.AbsoluteSkew, 0
 r.Rotate s.RotationAngle
End Sub


Преобразовать мноугольник с одним числом сторон в другой

Sub Test()
 Dim s As Shape
 For Each s In ActivePage.Shapes
  If s.Type = cdrPolygonShape Then
   s.Polygon.Sides = 5
   s.Polygon.Type = cdrStar
  End If
 Next s
End Sub

Вращение эллипса со случайной  заливкой цветом

Sub Test()
 Const NumLeafs As Long = 11
 Dim pal As Palette
 Dim s As Shape
 Dim i As Long, NumColors As Long
 If ActivePalette Is Nothing Then
  Set pal = Palettes.Open(Application.SetupPath & "Custom\coreldrw.cpl")
 Else
  Set pal = ActivePalette
 End If
 NumColors = pal.ColorCount
 For i = 1 To NumLeafs
  If s Is Nothing Then
   Set s = ActiveLayer.CreateEllipse(5, 5, 7, 6)
   s.RotationCenterX = 4
   s.RotationCenterY = 5.5
  Else
  s.Duplicate
  End If
  s.Fill.ApplyUniformFill pal.Color(Rnd() * NumColors + 1)
  s.Rotate 360 / NumLeafs
 Next i
End Sub


 

МК ставит точки на кривой

Sub Test()
 Dim sp As SnapPoint
 For Each sp In ActiveShape.SnapPoints
  ActiveLayer.CreateEllipse2 sp.PositionX, sp.PositionY, 0.1
 Next sp
End Sub


 

Двигать случайным образом

Sub Test()
 Dim x As Double, y As Double, max As Double
 Dim n As Node
 If ActiveShape Is Nothing Then
  MsgBox "Select an object first", vbCritical
  Exit Sub
 End If
 If ActiveShape.Type <> cdrCurveShape Then ActiveShape.ConvertToCurves
 If ActiveShape.Type <> cdrCurveShape Then
  MsgBox "Unable to convert the object to curve", vbCritical
  Exit Sub
 End If
 ActiveShape.GetSize x, y
 If x < y Then max = y / 10 Else max = x / 10
 For Each n In ActiveShape.Curve.Nodes

n.Move (Rnd() - 0.5) * max, (Rnd() - 0.5) * max
 Next n
End Sub


Добавить в контейнер

Sub Test()
 Dim rect As Shape, ell As Shape
 Set rect = ActiveLayer.CreateRectangle(0, 0, 4, 3)
 rect.Fill.UniformColor.RGBAssign 255, 0, 0
 Set ell = ActiveLayer.CreateEllipse(2, 1, 5, 4)
 ell.Fill.UniformColor.RGBAssign 255, 255, 0
 ell.AddToPowerClip rect
End Sub

Клонировать

Sub Test()
 Dim rs As Shape, cs As Shape
 Set rs = ActiveLayer.CreateRectangle2(0, 0, 4, 2)
 rs.Fill.UniformColor.CMYKAssign 0, 100, 100, 0
 Set cs = rs.Clone(0, 3)
 cs.Fill.UniformColor.CMYKAssign 100, 0, 100, 0
End Sub

Комбиноровать в новом документе

Sub Test()
 Dim doc As Document
 Dim e1 As Shape, e2 As Shape
 Set doc = CreateDocument()
 Set e1 = doc.ActiveLayer.CreateEllipse2(4, 3, 2)
 Set e2 = doc.ActiveLayer.CreateEllipse2(4, 5, 3)
 ' Here e2 is selected. Just add e1 to selection
 e1.Selected = True
 Set e1 = doc.Selection.Combine
 e1.Fill.UniformColor.CMYKAssign 100, 0, 0, 0
End Sub

Рисовать с тенью

Sub Test()
 Dim r As Shape, s As Shape
 Set r = ActiveLayer.CreateRectangle(0, 0, 5, 5)
 r.Fill.UniformColor.CMYKAssign 100, 0, 0, 0
 Set s = ActiveLayer.CreateEllipse2(3, 3, 2)
 s.Fill.UniformColor.CMYKAssign 0, 100, 100, 0
 Set s = s.ConvertToBitmapEx(cdrCMYKColorImage, False, True)
 s.CreateDropShadow cdrDropShadowFlat, 80, 10, 0.5, -0.5, CreateCMYKColor(0, 50, 50, 50)
 r.CreateSelection
 s.Selected = True
 ActiveSelection.Group
End Sub

Последовательное преобразование одного эллипса в другой

Sub Test()
 Dim sPath As Shape, s1 As Shape, s2 As Shape
 Dim eff As Effect
 Set sPath = ActiveLayer.CreateCurveSegment(1, 6.5, 5, 8.5, 2, 72, 1.8, 180)
 Set s1 = ActiveLayer.CreateEllipse(0.953386, 6.731929, 1.838858, 6.027165)
 s1.Fill.UniformColor.CMYKAssign 0, 100, 100, 0
 Set s2 = ActiveLayer.CreateEllipse(4.838622, 9.045, 5.597598, 8.21374)
 s2.Fill.UniformColor.CMYKAssign 0, 0, 100, 0
 Set eff = s2.CreateBlend(s1, 10)
 eff.Blend.Path = sPath
End Sub


 

МК рисует магический глаз

The following example draws a magnifying glass.

Sub Test()
 Dim sText As Shape, sRect As Shape, sCircle1 As Shape, sCircle2 As Shape
 Set sText = ActiveLayer.CreateArtisticText(2.8, 7.5, "Magnify")
 With sText.Text.FontProperties
  .Name = "Arial"
  .Size = 64
 End With
 sText.Text.AlignProperties.Alignment = cdrCenterAlignment
 sText.CreateEnvelope 4, cdrEnvelopePutty, False
 ActiveDocument.ReferencePoint = cdrCenter
 sText.Stretch 1, 1.6
 Set sRect = ActiveLayer.CreateRectangle(2.164134, 5.358543, 6.338504, 4.798346)

With sRect
  With .Fill.ApplyFountainFill(CreateRGBColor(255, 0, 0), CreateRGBColor(251, 0, 81), , -90)
   .Colors.Add CreateRGBColor(255, 0, 0), 1
   .Colors.Add CreateRGBColor(253, 253, 213), 23
   .StartX = 4.251319
   .StartY = 5.358543
   .EndX = 4.251319
   .EndY = 4.798346
  End With
  .Rotate -60
  .Move 0.469843, -0.397559
  .Outline.Type = cdrNoOutline
 End With
 Set sCircle1 = ActiveLayer.CreateEllipse(1.116024, 9.514843, 4.459134, 6.171732)

sCircle1.Outline.SetProperties 0.3, OutlineStyles(0), CreateCMYKColor(0, 100, 100, 0)
 Set sCircle2 = sCircle1.Duplicate
 With sCircle2.Outline
  .Width = 0.05
  .Color.CMYKAssign 0, 0, 0, 0
 End With
 sCircle2.CreateBlend sCircle1
End Sub


Шахматы по сторонам куба

Sub Test()
 Dim sGrid As Shape, s As Shape
 Dim b As Boolean, n As Long
 Set sGrid = ActiveLayer.CreateGridBoxes(1.549724, 7.436693, 3.067677, 5.91874, 4, 4)
 b = True
 n = 0
 For Each s In sGrid.Shapes
  If b Then
   s.Fill.UniformColor.RGBAssign 0, 0, 0
  Else
   s.Fill.UniformColor.RGBAssign 255, 255, 255
  End If
  n = n + 1
  If (n Mod 4) <> 0 Then b = Not b
 Next s
 Set s = sGrid.Duplicate
 s.SetBoundingBox 1.549724, 7.436693, 1.517953, 0.451447

s.CreatePerspective , , 6.984024, 9.839248
 Set s = sGrid.Duplicate
 s.SetBoundingBox 3.068583, 5.91874, 0.7395965, 1.517953
 s.CreatePerspective 6.984024, 9.839248
End Sub


Удалить активный объект

Sub Test()
 ActiveShape.Cut
End Sub


 

МК рисует полумесяц

The following example creates a crescent by trimming one ellipse with another.
 

Sub Test()
 Dim s1 As Shape, s2 As Shape
 Set s1 = ActiveLayer.CreateEllipse(1.947283, 7.707756, 4.278425, 5.376614)
 Set s2 = s1.Duplicate(0.560197, 0)
 s2.Trim s1
 s2.Delete
End Sub


МК определяет центр полилинии

The following example creates a small circle in the center of each shape on the page.

Sub Test()
 Dim x As Double, y As Double
 Dim s As Shape
 ActiveDocument.ReferencePoint = cdrCenter
 For Each s In ActivePage.Shapes
  s.GetPosition x, y
  ActiveLayer.CreateEllipse2 x, y, 0.03
 Next s
End Sub


Группирует

Sub Test()
 Dim g As Shape
 Set g = ActiveSelection.Group
 g.Layer = ActiveLayer
End Sub


Сложение цветов

Sub Test()
 Dim s(0 To 2) As Shape
 Dim si(0 To 2) As Shape
 Dim sm As Shape
 Dim x As Double, y As Double
 Dim i As Long, n As Long
 Dim r As Long, g As Long, b As Long
 Dim c1 As Color, c2 As Color
 For i = 0 To 2
  x = ActivePage.SizeWidth / 2 + 1 * Cos(i * 2.09439507)
  y = ActivePage.SizeHeight / 2 + 1 * Sin(i * 2.09439507)
  Set s(i) = ActiveLayer.CreateEllipse2(x, y, 1.5)
  r = -255 * (i = 0)
  g = -255 * (i = 1)
  b = -255 * (i = 2)

s(i).Fill.UniformColor.RGBAssign r, g, b
 Next i
 For i = 0 To 2
  n = (i + 1) Mod 3
  Set si(i) = s(i).Intersect(s(n))
  Set c1 = s(i).Fill.UniformColor
  Set c2 = s(n).Fill.UniformColor
  r = c1.RGBRed + c2.RGBRed
  g = c1.RGBGreen + c2.RGBGreen
  b = c1.RGBBlue + c2.RGBBlue
  si(i).Fill.UniformColor.RGBAssign r, g, b
 Next i
 Set sm = si(1).Intersect(si(2))
 sm.Fill.UniformColor.RGBAssign 255, 255, 255
End Sub


Передвинуть на шаг вперед

Sub Test()
 ActiveShape.OrderForwardOne
End Sub


Вытащить из контейнера

Sub Test()
 Dim s As Shape, ss As Shape
 Dim p As PowerClip
 On Error Resume Next
 For Each s In ActivePage.Shapes
  Set p = Nothing
  Set p = s.PowerClip
  If Not p Is Nothing Then
   For Each ss In p.Shapes
    If ss.Type = cdrEllipseShape Then
     ActiveDocument.ClearSelection
     ss.RemoveFromContainer
    End If
   Next ss
  End If
 Next s
End Sub


Вращение

Sub Test()
 Const NumLeafs As Long = 11
 Dim pal As Palette
 Dim s As Shape
 Dim i As Long, NumColors As Long
 Set s = Nothing
 If ActivePalette Is Nothing Then
  Set pal = Palettes.Open(Application.SetupPath & "Custom\coreldrw.cpl")
 Else
  Set pal = ActivePalette
 End If
 NumColors = pal.ColorCount
 For i = 1 To NumLeafs
  If s Is Nothing Then
   Set s = ActiveLayer.CreateEllipse(5, 5, 7, 6)
   s.RotationCenterX = 4
   s.RotationCenterY = 5.5

Else
   s.Duplicate
  End If
  s.Fill.ApplyUniformFill pal.Color(Rnd() * NumColors + 1)
  s.RotateEx 360 / NumLeafs, ActivePage.SizeHeight / 2, ActivePage.SizeWidth / 2
 Next i
End Sub


МК рисует куб в изометрии

Sub Test()
 Dim s1 As Shape, s2 As Shape, s3 As Shape
 Set s1 = ActiveLayer.CreateRectangle(2.5, 8.5, 4.5, 6.5)
 s1.Fill.UniformColor.CMYKAssign 0, 100, 100, 0
 Set s2 = s1.Duplicate
 s2.Fill.UniformColor.CMYKAssign 100, 0, 0, 0
 ActiveDocument.ReferencePoint = cdrTopLeft
 s2.Stretch 0.866025, 1
 s2.Skew 0, -30
 s2.Move -0.866025, 0.5
 Set s3 = s1.Duplicate
 s3.Fill.UniformColor.CMYKAssign 0, 0, 100, 0
 s3.Stretch 0.866025, 1
 s3.Skew 0, 30
 s3.Move 0.866025, -0.5

s1.Stretch 0.866025, 1
 s1.Skew 0, 30
 s1.Rotate -60
 s1.Move 0, 1
End Sub


МК рисует арку

The following example creates a circle and a square, and welds them together.

Sub Test()
 Dim s1 As Shape, s2 As Shape
 Dim s As Shape
 Set s1 = ActiveLayer.CreateEllipse2(4, 5, 2)
 Set s2 = ActiveLayer.CreateRectangle2(2, 1, 4, 4)
 Set s = s1.Weld(s2)
 s.Fill.UniformColor.CMYKAssign 100, 0, 0, 0
End Sub


Масштаб и сдвинуть

   Dim s305 As Shape
   Set s305 = ActiveSelection.Group
   s305.Stretch 0.5                              ' масштаб
   s305.Move -4.498425, -0.232677      ' сдвинуть


Сделать полигон (crvs673) активным и залить цветом

   Set s674 = ActiveLayer.CreateCurve(crvs673)
   s674.Fill.UniformColor.CMYKAssign 0, 0, 100, 0


Полезные макросы
Еще некоторые МК, полученные во время работы
 



МК для для построения мандал
1. Круг, вписанный 4-угольника, в него 8-угольника и 4-угольник  (рис.)
2. Нумерологическая мандала личности: (см. рис.)
Первая МК строит круг, 4-угольник, 8-угольника и 4-угольник
Вторая МК + функция Orto() строят поверх первой МК мандалу сущности (в тексте второй МК можно задать свои  день, месяц и год).
Третья МК строит общую мандалу (сущности+личности) - задайте в z1 - свои дату рождения, в z2 - имя, z3 - отчество, z4 - фамилию
На этом рис.  мандала МГУ (05.03.1944) получена в CorelDraw c последующей растяжкой цвета.
Макрос построение полной мандалы одной МК (цвет круга, 4-угольника, 8-угольника и самой мандалы задается случайным образом).
Макрос песни на примере "Морской университет". Словосочетания строк своего текста задавать без пробелов.
Вальс "Приморье"  (МК)


* Задание данных форм аналогично и в 10-м и 11-м CorelDraw
Основы языка программирования  Visual Basic for Applications