Sub Macro1()

        z1 = "Набегаетволна,солонаивольна,внашигавани,"
        z2 = "Расходясьзакормоювкипящийкильватерныйслед."
        z3 = "Инаднашейдалекой,наднашейзаветнойокраиной"
        z4 = "Сопкивтуманахнебокачает,"
        z1All = z1 + z2 + z3 + z4
 
        z5 = "Сопкивтуманахнебокачает,"
        z6 = "Чайкамивеселоветериграет."
        z7 = "Пенавутесах,моресмеется,"
        z8 = "Всякийвернется,ктоздесьпобывает."
        z2All = z5 + z6 + z7 + z8
 
        z9 = "Волнывзаливахсверкаютсалютом,"
        z10 = "Бризнаполняетвечеруютом"
        z11 = "Краймойродимыйвновьзасыпает"
        z12 = "Вновьнаступаетновоеутро."
        z3All = z9 + z10 + z11 + z12
 
        z13 = "Вэтоткрайзолотой,приведенныйсудьбой,незаброшенный"
        z14 = "Тыдостоинтого,чтобыпростодостойнопожить."
        z15 = "Чтобыбыловозможночего-тоотведатьхорошего,"
        z16 = "Чтобывыраститьсад,чтобыдомссыновьямисложить."
        z4All = z13 + z14 + z15 + z16
 
        z17 = "Хотьнакартахроссийскихсчитаетсяточкоюдальнею,"
        z18 = "Изакрытымдлямногихсчиталсявтечениелет,"
        z19 = "ЗолотоеПриморьелюбимаянашаокраина,"
        z20 = "ИотсюдасвостокаприходитвРоссиюрассвет."
        z5All = z17 + z18 + z19 + z20
 
        z21 = "Городприморскийскрикамичаек,"
        z22 = "Городприморскийсопкикачают."
        z23 = "Пенойсоленойберегумоет,"
        z24 = "Крайнашнавекисердцемстобою."
        z6All = z21 + z22 + z23 + z24
 
    Macro2 z1, 0.25, -3, 0
    Macro2 z2, 0.25, -1.5, 0
    Macro2 z3, 0.25, 0, 0
    Macro2 z4, 0.25, 1.5, 0
    Macro2 z1All, 0.25, 3, 0
    Macro2 z5, 0.25, -3, -1.5
    Macro2 z6, 0.25, -1.5, -1.5
    Macro2 z7, 0.25, 0, -1.5
    Macro2 z8, 0.25, 1.5, -1.5
    Macro2 z2All, 0.25, 3, -1.5
    Macro2 z9, 0.25, -3, -3
    Macro2 z10, 0.25, -1.5, -3
    Macro2 z11, 0.25, 0, -3
    Macro2 z12, 0.25, 1.5, -3
    Macro2 z3All, 0.25, 3, -3
    Macro2 z13, 0.25, -3, -4.5
    Macro2 z14, 0.25, -1.5, -4.5
    Macro2 z15, 0.25, 0, -4.5
    Macro2 z16, 0.25, 1.5, -4.5
    Macro2 z4All, 0.25, 3, -4.5
 
    Macro2 z17, 0.25, -3, -6
    Macro2 z18, 0.25, -1.5, -6
    Macro2 z19, 0.25, 0, -6
    Macro2 z20, 0.25, 1.5, -6
    Macro2 z5All, 0.25, 3, -6
 
    Macro2 z21, 0.25, -3, -7.5
    Macro2 z22, 0.25, -1.5, -7.5
    Macro2 z23, 0.25, 0, -7.5
    Macro2 z24, 0.25, 1.5, -7.5
    Macro2 z5All, 0.25, 3, -7.5
 
End Sub
 
Sub Macro2(zz, Mf, Sx, Sy)

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

                        nzz = Len(zz)
                        ' MsgBox "nzz = " & nzz
 
                        ma = 0.25
                        r = 10 * ma
                        xc = 16 * ma
                        yc = 35 * ma
                        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 * 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
 
                  Dim s(260)
 
                        For m = 1 To nzz
                          si = Mid(zz, m, 1)
                          s(m) = KodBukva(si)
                          ' MsgBox "s(m) = " & s(m)
                         Next
 
 
 
                  Dim x(260)
                  Dim y(260)
 
 
                  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)
 
                        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
                        ActiveDocument.ReferencePoint = cdrCenter
                        s5.Stretch Mf  ' масштаб
                        s5.Move Sx, Sy  ' сдвинуть
                        s51.Stretch Mf  ' масштаб
                        s51.Move Sx, Sy   ' сдвинуть
                        s644.Stretch Mf  ' масштаб
                        s644.Move Sx, Sy   ' сдвинуть
                        s645.Stretch Mf  ' масштаб
                        s645.Move Sx, Sy   ' сдвинуть
' Антены
 
 
              ro = ma * 1
              r = ma * Sqr(5 * 5 + 5 * 5)
              x1 = xc + r
              y1 = yc
              x2 = xc + r + ma * 0.5
              y2 = yc
              x3 = xc + r + ma * 0.5 + ro
              y3 = yc
              Set s11 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
              Set s12 = ActiveLayer.CreateEllipse2(x3, y3, ro)
              s12.Fill.UniformColor.RGBAssign n1, n2, n3
 
              x1 = xc - r
              y1 = yc
              x2 = xc - r - ma * 0.5
              y2 = yc
              x3 = xc - r - ma * 0.5 - ro
              y3 = yc
              Set s13 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
              Set s14 = ActiveLayer.CreateEllipse2(x3, y3, ro)
              s14.Fill.UniformColor.RGBAssign n1, n2, n3
 
 
              x1 = xc
              y1 = yc + r
              x2 = xc
              y2 = yc + r + ma * 0.5
              x3 = xc
              y3 = yc + r + ma * 0.5 + ro
              Set s15 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
              Set s16 = ActiveLayer.CreateEllipse2(x3, y3, ro)
              s16.Fill.UniformColor.RGBAssign n1, n2, n3
 
              x1 = xc
              y1 = yc - r
              x2 = xc
              y2 = yc - r - ma * 0.5
              x3 = xc
              y3 = yc - r - ma * 0.5 - ro
              Set s17 = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
              Set s18 = ActiveLayer.CreateEllipse2(x3, y3, ro)
              s18.Fill.UniformColor.RGBAssign n1, n2, n3
                  ActiveDocument.ClearSelection
                  s11.AddToSelection
                  s12.AddToSelection
                  s13.AddToSelection
                  s14.AddToSelection
                  s15.AddToSelection
                  s16.AddToSelection
                  s17.AddToSelection
                  s18.AddToSelection
                  Dim s1433 As Shape
                  Set s1433 = ActiveSelection.Group
                  ActiveDocument.ReferencePoint = cdrCenter
                  s1433.Stretch Mf
                  s1433.Move Sx, Sy
    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 = 35 * 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