Attribute VB_Name = "Module1"
Dim z1 As String, z2 As String, z3 As String, z4 As String
Dim zz, nzz
Sub Макрос1()
 
    '
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Имя"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Отчество"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Фамилия"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Ваш знак или мантра"
    Range("A2:B2").Select
    Columns("A:A").ColumnWidth = 10.78
    Columns("B:B").ColumnWidth = 14.11
    Columns("C:C").ColumnWidth = 14
    Columns("D:D").ColumnWidth = 20.89
 
    z1 = InputBox("Введите ваше имя", "Мандала")
    z2 = InputBox("Введите ваше отчество", "Мандала")
    z3 = InputBox("Введите ваше фамилию", "Мандала")
    z4 = InputBox("Введите ваш знак или мантру", "Мандала")
    Range("A2").Select
    ActiveCell.FormulaR1C1 = z1
    Range("B2").Select
    ActiveCell.FormulaR1C1 = z2
    Range("C2").Select
    ActiveCell.FormulaR1C1 = z3
    Range("D2").Select
    ActiveCell.FormulaR1C1 = z4
    Range("B3").Select
 
    ' MsgBox "Имя  = " & z1 + z2 + z3 + z4
    ' Переводим в 9-арканную ск
    z1 = Replace(z1, "0", "") ' убираются нули
    z2 = Replace(z2, "0", "") ' убираются нули
    z3 = Replace(z3, "0", "") ' убираются нули
    z4 = Replace(z4, "0", "") ' убираются нули, если код из цифр
    zz = z1 + z2 + z3 + z4
    nzz = Len(zz)
    ' MsgBox "z4 = " & z4
    Fun1  ' строим оболочку
    Fun2  ' строим мандалу
    fun3  ' обозначаем точки
 
    Range("A20:D20").Select
    ActiveCell.FormulaR1C1 = "Примечание: запустите Макрос1 и введите данные"
    ' антенны
    ActiveSheet.Shapes.AddShape(msoShapeOval, 132, 55, 16, 16).Select
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 42
    ActiveSheet.Shapes.AddShape(msoShapeOval, 132, 206#, 16, 16).Select
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 41
    ActiveSheet.Shapes.AddShape(msoShapeOval, 207#, 131, 16#, 16#).Select
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 41
    ActiveSheet.Shapes.AddShape(msoShapeOval, 53.4, 131, 16#, 16#).Select
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 41
    Range("A23:D23").Select
    ActiveCell.FormulaR1C1 = "Расчет:"
    Calc
    Range("A34:D34").Select
    ActiveCell.FormulaR1C1 = "Анализ:"
    Range("A35:D35").Select
    ActiveCell.FormulaR1C1 = "Наличие линии 2-5 - вы способны к белой магии;"
    Range("A36:D36").Select
    ActiveCell.FormulaR1C1 = "Наличие линии 5-8 - вы способны к черной магии;"
    Range("A37:D37").Select
    ActiveCell.FormulaR1C1 = "Наличие треугольника 4-2-6-4 - вы под защитой высших сил;"
    Range("A38:D38").Select
    ActiveCell.FormulaR1C1 = "Отсутствтвие 1-4, 4-7, 1-7 говорит о грехах в прошлой жизни;"
    Range("A39:D39").Select
    ActiveCell.FormulaR1C1 = "Отсутствтвие 1-4, 4-7, 1-7 говорит о грехах в прошлой жизни;"
    Range("A39:D39").Select
    ActiveCell.FormulaR1C1 = "Наличие 3-6-9 - объект живет и действует во имя будущего."
    Range("A40:D40").Select
    ActiveCell.FormulaR1C1 = "При отсутствии этой линии, человек обладает большей свободой"
    Range("A41:D41").Select
    ActiveCell.FormulaR1C1 = "но это говорит и изначальном нарушении гармонии во внутреннем мире"
End Sub

 Function Fun1() ' функция построения оболочки мандалы
 

  r = 180
  Dim xc, yc, x1, y1, x2, y2
  x1 = 50
  y1 = 50
  xc = x1 + r / 2
  yc = y1 + r / 2

  'Randomize
  'n1 = Int(Rnd(1) * 15 + 1)
  ActiveSheet.Shapes.AddShape(msoShapeOval, x1, y1, r, r).Select
  Selection.ShapeRange.Fill.ForeColor.SchemeColor = 45
  Selection.ShapeRange.Line.Weight = 1.5
  a = Sqr(r * r / 2)
  ActiveSheet.Shapes.AddShape(msoShapeRectangle, xc - a / 2, yc - a / 2, a, a).Select
  Selection.ShapeRange.Fill.ForeColor.SchemeColor = 41
  ' строим 8-гранник отрезками
    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)
 
    ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Select
    'Selection.ShapeRange.Line.Weight = 1#
    ActiveSheet.Shapes.AddLine(x3, y3, x2, y2).Select
    'Selection.ShapeRange.Line.Weight = 1#
    ActiveSheet.Shapes.AddLine(x3, y3, x4, y4).Select
    'Selection.ShapeRange.Line.Weight = 1#
    ActiveSheet.Shapes.AddLine(x5, y5, x4, y4).Select
    'Selection.ShapeRange.Line.Weight = 1#
    ActiveSheet.Shapes.AddLine(x5, y5, x6, y6).Select
    'Selection.ShapeRange.Line.Weight = 1#
    ActiveSheet.Shapes.AddLine(x7, y7, x6, y6).Select
    'Selection.ShapeRange.Line.Weight = 1#
    ActiveSheet.Shapes.AddLine(x7, y7, x8, y8).Select
    'Selection.ShapeRange.Line.Weight = 1#
    ActiveSheet.Shapes.AddLine(x8, y8, x1, y1).Select
    'Selection.ShapeRange.Line.Weight = 1#
    ' поставить точки
 
End Function
 
           Function Fun2()
 
                            Dim s(60)
                            Dim Kod As String
                                For m = 1 To nzz
                                    si = Mid(zz, m, 1)
                                    ' MsgBox "si = " & si
                                    s(m) = KodBukva(si)
                                    Kod = Kod + Str(s(m))
                                   Next
                                   ' Kod = Kod + Str(s(1))
 
 
 
                            Dim x(60)
                            Dim y(60)
 
 
                             For i = 1 To nzz
                                x(i) = orto(s(i), yi)
                                y(i) = yi
                                ' MsgBox "y{i} = " & y(i)
                             Next
 
                For n = 1 To nzz - 1
                    ActiveSheet.Shapes.AddLine(x(n), y(n), x(n + 1), y(n + 1)).Select
                Next
                ActiveSheet.Shapes.AddLine(x(nzz), y(nzz), x(1), y(1)).Select
 
 
    End Function
 
                        Function orto(sn, y99)
 
                                  r = 180
                                  a = Sqr(r * r / 2)
                                  a2 = Sqr(a * a / 2)
                                  xc = 50 + r / 2
                                  yc = 50 + r / 2
' ActiveSheet.Shapes.AddShape(msoShapeOval, xc, yc, 4, 4).Select
                                  x11 = xc - a2 / 2
                                  y11 = yc - a2 / 2

                                  ' MsgBox "y11 = " & y11
                                  x12 = xc
                                  y12 = yc - a2 / 2
                                  x13 = xc + a2 / 2
                                  y13 = yc - a2 / 2
                                  x14 = xc - a2 / 2
                                  y14 = yc

                                  x15 = xc
                                  y15 = yc

                                  x16 = xc + a2 / 2
                                  y16 = yc

                                  x17 = xc - a2 / 2
                                  y17 = yc + a2 / 2

                                  x18 = xc
                                  y18 = yc + a2 / 2

                                  x19 = xc + a2 / 2
                                  y19 = yc + a2 / 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
' ActiveSheet.Shapes.AddShape(msoShapeOval, x1, y1, 4, 4).Select
                    End Function
 
 Function fun3()
 
                                  r = 180
                                  a = Sqr(r * r / 2)
                                  a2 = Sqr(a * a / 2)
                                  xc = 50 + r / 2
                                  yc = 50 + r / 2

                                  x11 = xc - a2 / 2
                                  y11 = yc - a2 / 2
' поставить точки
    ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x11, y11, 0#, 0#).Select
    Selection.Characters.Text = "1"
                                  x12 = xc
                                  y12 = yc - a2 / 2
    ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x12, y12, 0#, 0#).Select
    Selection.Characters.Text = "2"
 
                                  x13 = xc + a2 / 2
                                  y13 = yc - a2 / 2
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x13, y13, 0#, 0#).Select
    Selection.Characters.Text = "3"
                                  x14 = xc - a2 / 2
                                  y14 = yc
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x14, y14, 0#, 0#).Select
    Selection.Characters.Text = "4"
                                  x15 = xc
                                  y15 = yc
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x15, y15, 0#, 0#).Select
    Selection.Characters.Text = "5"
                                  x16 = xc + a2 / 2
                                  y16 = yc
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x16, y16, 0#, 0#).Select
    Selection.Characters.Text = "6"
                                  x17 = xc - a2 / 2
                                  y17 = yc + a2 / 2
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x17, y17, 0#, 0#).Select
    Selection.Characters.Text = "7"
                                  x18 = xc
                                  y18 = yc + a2 / 2
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x18, y18, 0#, 0#).Select
    Selection.Characters.Text = "8"
                                  x19 = xc + a2 / 2
                                  y19 = yc + a2 / 2
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x19, y19, 0#, 0#).Select
    Selection.Characters.Text = "9"

                    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
 
    Function KodPlanet(cifra)
        If (cifra = 1) Then planeta = "Солнце"
        If (cifra = 2) Then planeta = "Луна"
        If (cifra = 3) Then planeta = "Марс"
        If (cifra = 4) Then planeta = "Меркурий"
        If (cifra = 5) Then planeta = "Юпитер"
        If (cifra = 6) Then planeta = "Венера"
        If (cifra = 7) Then planeta = "Сатурн"
        If (cifra = 8) Then planeta = "Уран"
        If (cifra = 9) Then planeta = "Нептун"
    KodPlanet = planeta
    End Function
 
 
Function vibrac(zzz, nc)
    n = 1
    Hislo = 0
    For m = 1 To nc
         si = Val(Mid(zzz, m, 1))
         Hislo = Hislo + si
    Next
If (Hislo > 9) Then
    s12 = Hislo Mod 10
    s11 = (Hislo - s12) / 10
    Hislo = s11 * 1 + s12 * 1
End If
If (Hislo > 9) Then
    s12 = Hislo Mod 10
    s11 = (Hislo - s12) / 10
    Hislo = s11 * 1 + s12 * 1
End If
    If (Hislo > 9) Then
    s12 = Hislo Mod 10
    s11 = (Hislo - s12) / 10
    Hislo = s11 * 1 + s12 * 1
End If
vibrac = Hislo
End Function
 

Function Calc()

Dim s(60)
Dim Kod As String
Kod = ""
For m = 1 To nzz
    si = Mid(zz, m, 1)
    ' MsgBox "si = " & si
    s(m) = KodBukva(si)
    Kod = Kod + Str(s(m))
Next
' Ваши все данные в 9-ти арканном коде
    Range("A21:D21").Select
    ActiveCell.FormulaR1C1 = "Ваши данные в 9-ти арканном коде будут:"
    Range("A22:D22").Select
    ActiveCell.FormulaR1C1 = Kod
    ' Код и вибрационное число сущности
 
    Vs = z1 + z2 + z3
    nvs = Len(Vs)
    Kod = ""
For m = 1 To nvs
    si = Mid(Vs, m, 1)
    ' MsgBox "si = " & si
    s(m) = KodBukva(si)
    Kod = Kod + Str(s(m))
Next
   'MsgBox "Код - как строка = " & Kod  ' строка
   ' MsgBox "Код - как строка = " & Val(Kod) / 10 ' как будто число!!!
 

    skt = Val(Kod)
    ' s99 = skt / 10
    Hislo1 = vibrac(skt, nvs)
    ' MsgBox "Вибрационное число сущности = " & Hislo1
 
    Range("A24:C24").Select
    ActiveCell.FormulaR1C1 = "Вибрационное число (ВЧ) сущности (ФИО) = "
    Range("D24").Select
    ActiveCell.FormulaR1C1 = Hislo1
    Pl1 = KodPlanet(Hislo1)
    Range("A25:C25").Select
    ActiveCell.FormulaR1C1 = "Связь сущности с планетой - "
    Range("D25").Select
    ActiveCell.FormulaR1C1 = Pl1
   ' код сущности: ВЧ + последняя цифра сущности
'  K1o.data = V11o.data * 10 + sf * 1
' Код связи
   K1 = Hislo1 * 10 + s(nvs)
   If (Hislo1 <> 0) Then
    x1 = orto(Hislo1, yi)
    y1 = yi
    x2 = orto(s(nvs), yi)
    y2 = yi
    ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Select
    Selection.ShapeRange.Line.Weight = 1.5
    End If
    ' MsgBox "код связи = " & K1
    Range("A26:C26").Select
    ActiveCell.FormulaR1C1 = "Код связи - "
    Range("D26").Select
    ActiveCell.FormulaR1C1 = K1
 
 
' расчеты для мантры
 

    ' Вибрационное число мантры
   Kod = ""
   nm = Len(z4)
   For m = 1 To nm
        si = Mid(z4, m, 1)
        ' MsgBox "si = " & si
        s(m) = KodBukva(si)
    Kod = Kod + Str(s(m))
Next

   skt = Val(Kod)
   Hislo2 = vibrac(skt, nm)
   ' MsgBox "Вибрационное число мантры = " & Hislo2
    ' MsgBox "Hislo = " & Hislo
 
    Range("A27:C27").Select
    ActiveCell.FormulaR1C1 = "Вибрационное число мантры = "
    Range("D27").Select
    ActiveCell.FormulaR1C1 = Hislo2
    Pl2 = KodPlanet(Hislo2)
    Range("A28:C28").Select
    ActiveCell.FormulaR1C1 = "Связь  мантры с планетой - "
    Range("D28").Select
    ActiveCell.FormulaR1C1 = Pl2
    ' код связи
    K2 = Hislo2 * 10 + s(nm)
    ' MsgBox "код связи = " & K2
    Range("A29:C29").Select
    ActiveCell.FormulaR1C1 = "Код связи - "
    Range("D29").Select
    ActiveCell.FormulaR1C1 = K2
 
   If (Hislo2 <> 0) Then

    x1 = orto(Hislo2, yi)
    y1 = yi
    x2 = orto(s(nm), yi)
    y2 = yi
    ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Select
    Selection.ShapeRange.Line.Weight = 1.5
   End If
    ' Золотое число
    Hislo = Hislo1 * 1 + Hislo2 * 1
    If (Hislo > 9) Then
        s12 = Hislo Mod 10
        s11 = (Hislo - s12) / 10
        Hislo = s11 * 1 + s12 * 1
    End If
    ' Код связи или Золотой ключ
    K3 = Hislo * 10 + s(nm)
 If (Hislo <> 0 And s(nm) <> 0) Then
    x1 = orto(Hislo, yi)
    y1 = yi
    x2 = orto(s(nm), yi)
    y2 = yi
    ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Select
    Selection.ShapeRange.Line.Weight = 2#
  End If
    Range("A30:C30").Select
    ActiveCell.FormulaR1C1 = "Золотое число = "
    Range("D30").Select
    ActiveCell.FormulaR1C1 = Hislo
    Pl3 = KodPlanet(Hislo)
    Range("A31:C31").Select
    ActiveCell.FormulaR1C1 = "Связь  ЗЧ с планетой - "
    Range("D31").Select
    ActiveCell.FormulaR1C1 = Pl3
    Range("A32:C32").Select
    ActiveCell.FormulaR1C1 = "Код связи или Золотой ключ - "
    Range("D32").Select
    ActiveCell.FormulaR1C1 = K3
End Function