' Построение мандалы одной МК сектора - прямоугольники
 
  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()
 
                      ' Задать дату рождения (в z1), имя в z2, Отчество z3, фамилию (z4)

 
                                  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
 

' Антены
    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
    Dim s1 As Shape, s2 As Shape
    Set s1 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
    Set s2 = ActiveLayer.CreateRectangle2(x2, y2 - ro, 2 * ro / 3, 2 * ro)
    s2.Fill.UniformColor.RGBAssign n1, n2, n3
 
    x1 = xc - r
    y1 = yc
    x2 = xc - r - m * 0.5
    y2 = yc
    Set s1 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
    Set s2 = ActiveLayer.CreateRectangle2(x1 - ro, y1 - ro, 2 * ro / 3, 2 * ro)
    s2.Fill.UniformColor.RGBAssign n1, n2, n3
 
    x1 = xc
    y1 = yc + r
    x2 = xc
    y2 = yc + r + m * 0.5
    Set s1 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
    Set s2 = ActiveLayer.CreateRectangle2(x2 - ro, y2, 2 * ro, 2 * ro / 3)
    s2.Fill.UniformColor.RGBAssign n1, n2, n3
 
    x1 = xc
    y1 = yc - r
    x2 = xc
    y2 = yc - r - m * 0.5
    Set s1 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
    Set s2 = ActiveLayer.CreateRectangle2(x1 - ro, y1 - ro, 2 * ro, 2 * ro / 3)
    s2.Fill.UniformColor.RGBAssign n1, n2, n3
    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