' МК мандалы текущего дня (без учета часа и минуты)
  Sub Macro1()
  ' Задать дату рождения (в z1), имя в z2, Отчество z3, фамилию (z4)

    z1 = "1141951"
    z1 = Replace(z1, "0", "") ' убираются нули
    z2 = "Владимир"         ' "Иван"
    z3 = "Васильевич"  ' "Семенович"
    z4 = "Щербинин"     '  "Сидоров"
    zz = z1 + z2 + z3 + z4
    MyDate = Date
    MyDat1 = Str(MyDate) ' преобразуем в строку
    MyDat2 = Replace(MyDat1, ".", "")  ' удаляем точки
    MyDat3 = Replace(MyDat2, "0", "") ' убираются нули
    ' MsgBox ("Len(MyDat3)  = " & Len(MyDat3))
    zz = MyDat3 + z2 + z3 + z4
    nzz = Len(zz)
    m = 0.25
    r = 10 * m
    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)
 
                                  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 * Sin(ug)
                                                y1 = yc + r * Cos(ug)
                                                i = 1
                                                ug = ug0 + i * step
                                                x2 = xc + r * Sin(ug)
                                                y2 = yc + r * Cos(ug)
                                                i = 2
                                                ug = ug0 + i * step
                                                x3 = xc + r * Sin(ug)
                                                y3 = yc + r * Cos(ug)
                                                i = 3
                                                ug = ug0 + i * step
                                                x4 = xc + r * Sin(ug)
                                                y4 = yc + r * Cos(ug)
                                                i = 4
                                                ug = ug0 + i * step
                                                x5 = xc + r * Sin(ug)
                                                y5 = yc + r * Cos(ug)
                                                i = 5
                                                ug = ug0 + i * step
                                                x6 = xc + r * Sin(ug)
                                                y6 = yc + r * Cos(ug)
                                                i = 6
                                                ug = ug0 + i * step
                                                x7 = xc + r * Sin(ug)
                                                y7 = yc + r * Cos(ug)
                                                i = 7
                                                ug = ug0 + i * step
                                                x8 = xc + r * Sin(ug)
                                                y8 = yc + r * Cos(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)
                                            s645.Fill.UniformColor.CMYKAssign 0, 0, 255, 0 ' ??????
                                  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

          ' Антены
              ro = m * 1
              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
              Set s1 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
              Set s1 = ActiveLayer.CreateEllipse2(x3, y3, ro)
              s1.Fill.UniformColor.RGBAssign n1, n2, n3
 
              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 n1, n2, n3
 
 
              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 n1, n2, n3
 
              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 n1, n2, n3
 
                                      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 Sub
 
 
                                  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

                    KodBukva = kod
 
                    End Function