' Построение мандалы одной МК (5 частей цвета с растяжкой - антены задаются сектором )
 
  Dim z1, z2, z3, z4, zz, nzz
 Sub Macro()
     Fun1
 

    ' "123456789" "Абвгдеёжз" "Доброгодня!"  "Доброгоздоровья!"  "Ялюблютебя"
    ' "Доброгопути" "Аум"
    ' "Солнце" "Луна"  "Марс" "Меркурий" "Юпитер" "Венера" "Сатурн" "Уран" "Нептун"

' Задать тантру и ФИО
 
                                  z1 = "Нептун"
                                  z1 = Replace(z1, "0", "") ' убираются нули
                                  z2 = ""         ' "Иван"
                                  z3 = ""  ' "Семенович"
                                  z4 = ""     '  "Сидоров"
                                  zz = z1 ' + z2 + z3 + z4
                                  nzz = Len(zz)
     Fun2
  End Sub
 
    Function Fun1()
 
                                  m = 0.25
                                  r = 10 * m
                                  Dim xc, yc, x1, y1, x2, y2
                                  xc = 16 * m
                                  yc = 29 * m
                                  x1 = xc - r
                                  y1 = yc - r
                                  x2 = xc + r
                                  y2 = yc + r
                                  Dim s51 As Shape
                                  Set s51 = ActiveLayer.CreateEllipse(x1, y1, x2, y2, 90#, 90#, False)
                                    '         s51.Fill.UniformColor.RGBAssign 88, 197, 240
                        Randomize
                        n1 = Int(Rnd(1) * 250 + 1)
                        n2 = Int(Rnd(1) * 250 + 1)
                        n3 = Int(Rnd(1) * 250 + 1)
                        s51.Fill.UniformColor.RGBAssign n1, n2, n3
 
                                  a = 2 * Sqr(r * r / 2)
                                  x1 = (-a / 2) + xc
                                  y1 = (-a / 2) + yc
                                  Dim s644 As Shape
                                  Dim crvs644 As Curve
                                  Set crvs644 = CreateCurve(ActiveDocument)
                                  With crvs644.CreateSubPath(x1, y1)
                                      .AppendLineSegment x1 + a, y1
                                      .AppendLineSegment x1 + a, y1 + a
                                      .AppendLineSegment x1, y1 + a
                                      .AppendLineSegment x1, y1
                                      .Closed = True
                                  End With
                                  Set s644 = ActiveLayer.CreateCurve(crvs644)
                        '        s644.Fill.UniformColor.RGBAssign 255, 0, 0
                        Randomize
                        n1 = Int(Rnd(1) * 250 + 1)
                        n2 = Int(Rnd(1) * 250 + 1)
                        n3 = Int(Rnd(1) * 250 + 1)
                        s644.Fill.UniformColor.RGBAssign n1, n2, n3

 
                                r = a / 2
                                  PI = 3.14
                                  ug0 = 0
                                  step = PI / 4
                                      i = 0
                                      ug = ug0 + i * step
                                      x1 = xc + r * Cos(ug)
                                      y1 = yc + r * Sin(ug)
                                      i = 1
                                      ug = ug0 + i * step
                                      x2 = xc + r * Cos(ug)
                                      y2 = yc + r * Sin(ug)
                                      i = 2
                                      ug = ug0 + i * step
                                      x3 = xc + r * Cos(ug)
                                      y3 = yc + r * Sin(ug)
                                      i = 3
                                      ug = ug0 + i * step
                                      x4 = xc + r * Cos(ug)
                                      y4 = yc + r * Sin(ug)
                                      i = 4
                                      ug = ug0 + i * step
                                      x5 = xc + r * Cos(ug)
                                      y5 = yc + r * Sin(ug)
                                      i = 5
                                      ug = ug0 + i * step
                                      x6 = xc + r * Cos(ug)
                                      y6 = yc + r * Sin(ug)
                                      i = 6
                                      ug = ug0 + i * step
                                      x7 = xc + r * Cos(ug)
                                      y7 = yc + r * Sin(ug)
                                      i = 7
                                      ug = ug0 + i * step
                                      x8 = xc + r * Cos(ug)
                                      y8 = yc + r * Sin(ug)
 
                                  Dim s645 As Shape
                                  Dim crvs645 As Curve
                                  Set crvs645 = CreateCurve(ActiveDocument)
                                  With crvs645.CreateSubPath(x1, y1)
                                      .AppendLineSegment x2, y2
                                      .AppendLineSegment x3, y3
                                      .AppendLineSegment x4, y4
                                      .AppendLineSegment x5, y5
                                      .AppendLineSegment x6, y6
                                      .AppendLineSegment x7, y7
                                      .AppendLineSegment x8, y8
                                      .AppendLineSegment x1, y1
                                      .Closed = True
                                  End With
                                  Set s645 = ActiveLayer.CreateCurve(crvs645)
 
                        Randomize
                        n1 = Int(Rnd(1) * 250 + 1)
                        n2 = Int(Rnd(1) * 250 + 1)
                        n3 = Int(Rnd(1) * 250 + 1)
                        s645.Fill.UniformColor.RGBAssign n1, n2, n3

' Делим плоскость 8-гранник на 5 частей
 
                                  Dim s646 As Shape
                                  Dim crvs646 As Curve
                                  Set crvs646 = CreateCurve(ActiveDocument)
                                  With crvs646.CreateSubPath(xc, yc)
                                      .AppendLineSegment x8, y8
                                      .AppendLineSegment x1, y1
                                      .AppendLineSegment x2, y2
                                      .AppendLineSegment xc, yc
                                      .Closed = True
                                  End With
                                  Set s646 = ActiveLayer.CreateCurve(crvs646)
                                  s646.Fill.UniformColor.RGBAssign 255, 0, 0
 
    s646.Fill.ApplyFountainFill CreateCMYKColor(0, 40, 20, 0), CreateCMYKColor(0, 0, 0, 0), cdrLinearFountainFill, -178.994914, 0, 13, 50, cdrDirectFountainFillBlend
    With s646.Fill.Fountain
        .StartX = 5.776807
        .StartY = 7.169539
        .EndX = 4.119319
        .EndY = 7.140461
    End With
s646.Outline.Type = cdrNoOutline
' MsgBox (" xc = " & xc)
' MsgBox (" yc = " & yc)
' 2-я часть - зеленая
                                  Dim s647 As Shape
                                  Dim crvs647 As Curve
                                  Set crvs647 = CreateCurve(ActiveDocument)
                                  With crvs647.CreateSubPath(xc, yc)
                                      .AppendLineSegment x2, y2
                                      .AppendLineSegment x3, y3
                                      .AppendLineSegment x4, y4
                                      .AppendLineSegment xc, yc
                                      .Closed = True
                                  End With
                                  Set s647 = ActiveLayer.CreateCurve(crvs647)
                                  s647.Fill.UniformColor.RGBAssign 0, 255, 0
    s647.Fill.ApplyFountainFill CreateCMYKColor(100, 0, 100, 0), CreateCMYKColor(0, 0, 0, 0), cdrLinearFountainFill, -90#, 0, 7, 24, cdrDirectFountainFillBlend
    With s647.Fill.Fountain
        .StartX = 3.944846
        .StartY = 8.841567
        .EndX = 3.944846
        .EndY = 7.140461
    End With
    s647.Outline.Type = cdrNoOutline
' 3-я часть - белая
                                  Dim s648 As Shape
                                  Dim crvs648 As Curve
                                  Set crvs648 = CreateCurve(ActiveDocument)
                                  With crvs648.CreateSubPath(xc, yc)
                                      .AppendLineSegment x4, y4
                                      .AppendLineSegment x5, y5
                                      .AppendLineSegment x6, y6
                                      .AppendLineSegment xc, yc
                                      .Closed = True
                                  End With
                                  Set s648 = ActiveLayer.CreateCurve(crvs648)
                                  s648.Fill.UniformColor.RGBAssign 255, 255, 255
    s648.Fill.ApplyFountainFill CreateCMYKColor(0, 0, 0, 10), CreateCMYKColor(0, 0, 0, 0), cdrLinearFountainFill, -1.134422, 0, 10, 39, cdrDirectFountainFillBlend
    With s648.Fill.Fountain
        .StartX = 2.330976
        .StartY = 7.082303
        .EndX = 3.799453
        .EndY = 7.053224
    End With
    s648.Outline.Type = cdrNoOutline
 

' 4-я часть - нижння (желтая)
                                  Dim s649 As Shape
                                  Dim crvs649 As Curve
                                  Set crvs649 = CreateCurve(ActiveDocument)
                                  With crvs649.CreateSubPath(xc, yc)
                                      .AppendLineSegment x6, y6
                                      .AppendLineSegment x7, y7
                                      .AppendLineSegment x8, y8
                                      .AppendLineSegment xc, yc
                                      .Closed = True
                                  End With
                                  Set s649 = ActiveLayer.CreateCurve(crvs649)
                                  s649.Fill.UniformColor.RGBAssign 255, 245, 0
    s649.Fill.ApplyFountainFill CreateCMYKColor(0, 0, 100, 0), CreateCMYKColor(0, 0, 0, 0), cdrLinearFountainFill, 88.72697, 0, 14, 24, cdrDirectFountainFillBlend
    With s649.Fill.Fountain
        .StartX = 3.930307
        .StartY = 5.730142
        .EndX = 3.959386
        .EndY = 7.038685
    End With
    s649.Outline.Type = cdrNoOutline

 
    Dim s947 As Shape
    Set s947 = ActiveLayer.CreateEllipse(4.831748, 8.07098, 3.17426, 6.413492, 90#, 90#, False)
    s947.Fill.UniformColor.CMYKAssign 100, 0, 0, 0
    s947.Fill.ApplyFountainFill CreateCMYKColor(0, 0, 0, 0), CreateCMYKColor(100, 0, 0, 0), cdrRadialFountainFill, 0#, 0, 0, 50, cdrDirectFountainFillBlend
    With s947.Fill.Fountain
        .StartX = 4.003004
        .StartY = 7.242236
        .EndX = 4.831748
        .EndY = 7.242236
    End With
    s947.Outline.Type = cdrNoOutline
 

' Антены
    m = 0.25
    xc = 16 * m
    yc = 29 * m
    ro = m * 1.5
    r = m * Sqr(5 * 5 + 5 * 5)
    x1 = xc + r
    y1 = yc
    x2 = xc + r + m * 0.5
    y2 = yc
    x3 = xc + r + m * 0.5 + ro
    y3 = yc
    Dim s1 As Shape, s2 As Shape
    Set s1 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
    Set s1 = ActiveLayer.CreateEllipse2(x3, y3, ro)
    s1.Fill.UniformColor.RGBAssign 255, 0, 0
    Set s2 = ActiveLayer.CreateRectangle2(x3 - ro / 5, y3 - ro, 2 * ro, 2 * ro)
    s2.Trim s1
    s2.Delete
 
    x1 = xc - r
    y1 = yc
    x2 = xc - r - m * 0.5
    y2 = yc
    x3 = xc - r - m * 0.5 - ro
    y3 = yc
    Set s1 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
    Set s1 = ActiveLayer.CreateEllipse2(x3, y3, ro)
    s1.Fill.UniformColor.RGBAssign 0, 255, 0
    Set s2 = ActiveLayer.CreateRectangle2(x3 - 2 * ro + ro / 5, y3 - ro, 2 * ro, 2 * ro)
    s2.Trim s1
    s2.Delete
 
    x1 = xc
    y1 = yc + r
    x2 = xc
    y2 = yc + r + m * 0.5
    x3 = xc
    y3 = yc + r + m * 0.5 + ro
    Set s1 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
    Set s1 = ActiveLayer.CreateEllipse2(x3, y3, ro)
    s1.Fill.UniformColor.RGBAssign 0, 255, 0
    Set s2 = ActiveLayer.CreateRectangle2(x3 - ro, y3 - ro / 5, 2 * ro, 2 * ro)
    s2.Trim s1
    s2.Delete
 
    x1 = xc
    y1 = yc - r
    x2 = xc
    y2 = yc - r - m * 0.5
    x3 = xc
    y3 = yc - r - m * 0.5 - ro
    Set s1 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
    Set s1 = ActiveLayer.CreateEllipse2(x3, y3, ro)
    s1.Fill.UniformColor.RGBAssign 255, 245, 0
    Set s2 = ActiveLayer.CreateRectangle2(x3 - ro, y3 - 2 * ro + ro / 5, 2 * ro, 2 * ro)
    s2.Trim s1
    s2.Delete
End Function

 ' Построение мандалы одной МК
          Function Fun2()
                      ' Задать дату рождения (в z1), имя в z2, Отчество z3, фамилию (z4)

                                  'z1 = ""
                                  'z1 = Replace(z1, "0", "") ' убираются нули
                                  'z2 = ""         ' "Иван"
                                  'z3 = ""  ' "Семенович"
                                  'z4 = ""     '  "Сидоров"
                                  'zz = z1 + z2 + z3 + z4
                                  'nzz = Len(zz)
 

 
                            Dim s(60)
 
                                  For m = 1 To nzz
                                    si = Mid(zz, m, 1)
                                    ' MsgBox "si = " & si
                                    s(m) = KodBukva(si)
                                    ' MsgBox "s(m) = " & s(m)
                                   Next
 
 
 
                            Dim x(60)
                            Dim y(60)
 
 
                            For i = 1 To nzz
                                x(i) = orto(s(i), yi)
                                y(i) = yi
                            '    MsgBox "y{k} = " & y(k)
                            Next
 
                                  Dim crvs5 As Curve
                                  Set crvs5 = CreateCurve(ActiveDocument)
                                  With crvs5.CreateSubPath(x(1), y(1))
                                    For n = 2 To nzz
                                    .AppendLineSegment x(n), y(n)
                                  Next
                                  .AppendLineSegment x(1), y(1)
                                     .Closed = True
                                  End With
                                  Set s5 = ActiveLayer.CreateCurve(crvs5)
                        '          s5.Fill.UniformColor.RGBAssign 255, 0, 0
                        Randomize
                        n1 = Int(Rnd(1) * 250 + 1)
                        n2 = Int(Rnd(1) * 250 + 1)
                        n3 = Int(Rnd(1) * 250 + 1)
                        s5.Fill.UniformColor.RGBAssign n1, n2, n3
    End Function
 
 
                        Function orto(sn, y99)
                                  m = 0.25
                                  r = 10 * m
                                  a = 2 * Sqr(r * r / 2)
                                  r = a / 2
                                  a = 2 * Sqr(r * r / 2)
                                  xc = 16 * m
                                  yc = 29 * m
                                  x11 = xc - a / 2
                                  y11 = yc + a / 2
                                  x12 = xc
                                  y12 = yc + a / 2
                                  x13 = xc + a / 2
                                  y13 = yc + a / 2
 
                                  x14 = xc - a / 2
                                  y14 = yc
                                  x15 = xc
                                  y15 = yc
                                  x16 = xc + a / 2
                                  y16 = yc
 
                                  x17 = xc - a / 2
                                  y17 = yc - a / 2
                                  x18 = xc
                                  y18 = yc - a / 2
                                  x19 = xc + a / 2
                                  y19 = yc - a / 2
 
 
                                  If (sn = 1) Then
                                      x1 = x11
                                      y1 = y11
                                  End If
                                  If (sn = 2) Then
                                      x1 = x12
                                      y1 = y12
                                  End If
                                  If (sn = 3) Then
                                      x1 = x13
                                      y1 = y13
                                  End If

                                  If (sn = 4) Then
                                      x1 = x14
                                      y1 = y14
                                  End If

                                  If (sn = 5) Then
                                      x1 = x15
                                      y1 = y15
                                  End If

                                  If (sn = 6) Then
                                      x1 = x16
                                      y1 = y16
                                  End If

                                  If (sn = 7) Then
                                      x1 = x17
                                      y1 = y17
                                  End If

                                  If (sn = 8) Then
                                      x1 = x18
                                      y1 = y18
                                  End If

                                  If (sn = 9) Then
                                      x1 = x19
                                      y1 = y19
                                  End If
                                  orto = x1
                                  y99 = y1
                    End Function
 
                      Function KodBukva(ltr)
 
              If (ltr = "1") Then kod = 1
              If (ltr = "2") Then kod = 2
              If (ltr = "3") Then kod = 3
              If (ltr = "4") Then kod = 4
              If (ltr = "5") Then kod = 5
              If (ltr = "6") Then kod = 6
              If (ltr = "7") Then kod = 7
              If (ltr = "8") Then kod = 8
              If (ltr = "9") Then kod = 9
 
              If (ltr = "А" Or ltr = "а") Then kod = 1
              If (ltr = "Б" Or ltr = "б") Then kod = 2
              If (ltr = "В" Or ltr = "в") Then kod = 3
              If (ltr = "Г" Or ltr = "г") Then kod = 4
              If (ltr = "Д" Or ltr = "д") Then kod = 5
              If (ltr = "Е" Or ltr = "е") Then kod = 6
              If (ltr = "Ё" Or ltr = "ё") Then kod = 7
              If (ltr = "Ж" Or ltr = "ж") Then kod = 8
              If (ltr = "З" Or ltr = "з") Then kod = 9
 
              If (ltr = "И" Or ltr = "и") Then kod = 1
              If (ltr = "Й" Or ltr = "й") Then kod = 2
              If (ltr = "К" Or ltr = "к") Then kod = 3
              If (ltr = "Л" Or ltr = "л") Then kod = 4
              If (ltr = "М" Or ltr = "м") Then kod = 5
              If (ltr = "Н" Or ltr = "н") Then kod = 6
              If (ltr = "О" Or ltr = "о") Then kod = 7
              If (ltr = "П" Or ltr = "п") Then kod = 8
              If (ltr = "Р" Or ltr = "р") Then kod = 9
 
 
              If (ltr = "С" Or ltr = "с") Then kod = 1
              If (ltr = "Т" Or ltr = "т") Then kod = 2
              If (ltr = "У" Or ltr = "у") Then kod = 3
              If (ltr = "Ф" Or ltr = "ф") Then kod = 4
              If (ltr = "Х" Or ltr = "х") Then kod = 5
              If (ltr = "Ц" Or ltr = "ц") Then kod = 6
              If (ltr = "Ч" Or ltr = "ч") Then kod = 7
              If (ltr = "Щ" Or ltr = "ш") Then kod = 8
              If (ltr = "Щ" Or ltr = "щ") Then kod = 9
 
              If (ltr = "Ъ" Or ltr = "ъ") Then kod = 1
              If (ltr = "Ы" Or ltr = "ы") Then kod = 2
              If (ltr = "ь" Or ltr = "ь") Then kod = 3
              If (ltr = "Э" Or ltr = "э") Then kod = 4
              If (ltr = "Ю" Or ltr = "ю") Then kod = 5
              If (ltr = "Я" Or ltr = "я") Then kod = 6
 
              If (ltr = ".") Then kod = 1
              If (ltr = ",") Then kod = 2
              If (ltr = "!") Then kod = 3
              If (ltr = "?") Then kod = 4
              If (ltr = ";") Then kod = 5
              If (ltr = "~") Then kod = 6
              If (ltr = "*") Then kod = 7
              If (ltr = "|") Then kod = 8
              If (ltr = "/") Then kod = 9
              If (ltr = "") Then kod = 5

          KodBukva = kod
 
          End Function