Построить классическую круглую натальную карту в Excel стандартными методами напрямую невозможно, так как графический движок Excel (диаграммы) жестко привязан к декартовой системе координат (сетка X и Y), гистограммам или биржевым графикам.
Однако, используя данные из таблиц и встроенный язык VBA, решить эту задачу можно.
VBA будет работать как графический редактор. Вместо построения диаграммы макрос будет буквально рисовать карту на листе Excel с помощью векторных фигур (ActiveSheet.Shapes.AddShape и AddLine).
Перед запуском кода убедитесь, что ваш рабочий лист выглядит следующим образом:
1. Столбец А: Двухбуквенное название планеты (например, SU, MO, ME, VE, MA).
2. Столбец B: Координата в десятичных градусах от 0 до 360 (например, 45,25, 120,5,).
3. Данные начинаются со строки 2 (строка 1 — для заголовков).
## Код макроса VBA
Чтобы вставить код: нажмите Alt + F11, выберите Insert -> Module, вставьте текст ниже и нажмите F5 для запуска.
Код:
Sub DrawAstrologyChart_Final()
Dim ws As Worksheet
Set ws = ActiveSheet
' 1. Очистка старых рисунков на листе
Dim shp As Shape
For Each shp In ws.Shapes
shp.Delete
Next shp
' 2. Геометрические настройки карты
Dim centerX As Double, centerY As Double
Dim rOuter As Double, rZodiacInner As Double, rPlanetCircle As Double
Dim rTextSigns As Double, rTextPlanets As Double
centerX = 400
centerY = 260
rOuter = 210 ' 1-й круг: Самая внешняя граница карты
rZodiacInner = 175 ' 2-й круг: Внутренняя граница Зодиака
rPlanetCircle = 135 ' 3-й круг: Линия положения планет
rTextSigns = 192.5 ' Исправлено: только число
rTextPlanets = 155# ' Исправлено: только число
Dim pi As Double
pi = 3.14159265358979
' Латинские сокращения знаков зодиака
Dim signs(0 To 11) As String
signs(0) = "AR": signs(1) = "TA": signs(2) = "GE": signs(3) = "CN"
signs(4) = "LE": signs(5) = "VI": signs(6) = "LI": signs(7) = "SC"
signs(8) = "SG": signs(9) = "CP": signs(10) = "AQ": signs(11) = "PI"
' 3. Рисуем три каркасных круга
ws.Shapes.AddShape(msoShapeOval, centerX - rOuter, centerY - rOuter, rOuter * 2, rOuter * 2).Fill.Transparency = 1
ws.Shapes.AddShape(msoShapeOval, centerX - rZodiacInner, centerY - rZodiacInner, rZodiacInner * 2, rZodiacInner * 2).Fill.Transparency = 1
ws.Shapes.AddShape(msoShapeOval, centerX - rPlanetCircle, centerY - rPlanetCircle, rPlanetCircle * 2, rPlanetCircle * 2).Fill.Transparency = 1
' 4. Рисуем сетку 12 знаков зодиака
Dim i As Integer
Dim angleRad As Double, midAngleRad As Double
Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
Dim sX As Double, sY As Double
Dim signBox As Shape
Dim signLine As Shape
For i = 0 To 11
angleRad = (i * 30) * pi / 180
x1 = centerX - rZodiacInner * Cos(angleRad)
y1 = centerY + rZodiacInner * Sin(angleRad)
x2 = centerX - rOuter * Cos(angleRad)
y2 = centerY + rOuter * Sin(angleRad)
Set signLine = ws.Shapes.AddLine(x1, y1, x2, y2)
signLine.Line.ForeColor.RGB = RGB(160, 160, 160)
midAngleRad = (i * 30 + 15) * pi / 180
sX = centerX - rTextSigns * Cos(midAngleRad)
sY = centerY + rTextSigns * Sin(midAngleRad)
Set signBox = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, sX - 12, sY - 10, 24, 20)
With signBox
.TextFrame.Characters.Text = signs(i)
.TextFrame.Characters.Font.Size = 9
.TextFrame.Characters.Font.Bold = True
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.MarginLeft = 0
.TextFrame.MarginRight = 0
.TextFrame.MarginTop = 0
.TextFrame.MarginBottom = 0
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
End With
Next i
' 5. Считывание планет из таблицы
Dim lastRow As Long
Dim r As Long
lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
If lastRow < 2 Then Exit Sub
Dim count As Long
count = lastRow - 1
ReDim pNames(1 To count) As String
ReDim pLongs(1 To count) As Double
ReDim pVisualLongs(1 To count) As Double
Dim idx As Long
idx = 1
For r = 2 To lastRow
If ws.Cells(r, 1).Value <> "" Then
pNames(idx) = ws.Cells(r, 1).Value
pLongs(idx) = Val(ws.Cells(r, 2).Value)
pVisualLongs(idx) = pLongs(idx)
idx = idx + 1
End If
Next r
count = idx - 1
' Сортировка планет (пузырьковый метод)
Dim j As Long, tempLong As Double, tempVis As Double, tempName As String
For i = 1 To count - 1
For j = i + 1 To count
If pVisualLongs(i) > pVisualLongs(j) Then
tempLong = pLongs(i): pLongs(i) = pLongs(j): pLongs(j) = tempLong
tempVis = pVisualLongs(i): pVisualLongs(i) = pVisualLongs(j): pVisualLongs(j) = tempVis
tempName = pNames(i): pNames(i) = pNames(j): pNames(j) = tempName
End If
Next j
Next i
' Радвижка близких надписей
Dim minDistance As Double
minDistance = 6.5
Dim passes As Integer
For passes = 1 To 5
For i = 1 To count
Dim nextIdx As Long
If i = count Then nextIdx = 1 Else nextIdx = i + 1
Dim diff As Double
diff = pVisualLongs(nextIdx) - pVisualLongs(i)
If diff < 0 Then diff = diff + 360
If diff < minDistance Then
pVisualLongs(i) = pVisualLongs(i) - (minDistance - diff) / 2
pVisualLongs(nextIdx) = pVisualLongs(nextIdx) + (minDistance - diff) / 2
If pVisualLongs(i) < 0 Then pVisualLongs(i) = pVisualLongs(i) + 360
If pVisualLongs(nextIdx) >= 360 Then pVisualLongs(nextIdx) = pVisualLongs(nextIdx) - 360
End If
Next i
Next passes
' 6. Отрисовка планет
Dim pX As Double, pY As Double
Dim markerX As Double, markerY As Double
Dim txtBox As Shape
For i = 1 To count
angleRad = pLongs(i) * pi / 180
markerX = centerX - rPlanetCircle * Cos(angleRad)
markerY = centerY + rPlanetCircle * Sin(angleRad)
ws.Shapes.AddShape(msoShapeOval, markerX - 2.5, markerY - 2.5, 5, 5).Fill.ForeColor.RGB = RGB(255, 0, 0)
Dim visAngleRad As Double
visAngleRad = pVisualLongs(i) * pi / 180
pX = centerX - rTextPlanets * Cos(visAngleRad)
pY = centerY + rTextPlanets * Sin(visAngleRad)
Set txtBox = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, pX - 12, pY - 10, 24, 20)
With txtBox
.TextFrame.Characters.Text = pNames(i)
.TextFrame.Characters.Font.Size = 9
.TextFrame.Characters.Font.Bold = True
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.MarginLeft = 0
.TextFrame.MarginRight = 0
.TextFrame.MarginTop = 0
.TextFrame.MarginBottom = 0
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
End With
Next i
End Sub
нанесение сетки домов
в моем примере данные берутся из ячеек столбцы O и P.
## Код макроса VBA
Код:
Sub DrawAstrologyHouses()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim centerX As Double, centerY As Double
Dim rOuter As Double, rZodiacInner As Double, rPlanetCircle As Double
centerX = 400: centerY = 260
rOuter = 210: rZodiacInner = 175: rPlanetCircle = 135
Dim rHouseExt As Double, rAscExt As Double
rHouseExt = rOuter + 5 ' Обычный хвостик куспида
rAscExt = rOuter + 25 ' Удлиненный хвостик для Асцендента (1-й дом)
Dim pi As Double: pi = 3.14159265358979
Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.count, "P").End(xlUp).Row
If lastRow < 2 Then Exit Sub
Dim r As Long, houseLong As Double, angleRad As Double
Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double, x3 As Double, y3 As Double, x4 As Double, y4 As Double
Dim houseLineInner As Shape, houseLineOuter As Shape
For r = 2 To lastRow
If ws.Cells(r, "P").Value <> "" And IsNumeric(ws.Cells(r, "P").Value) Then
houseLong = Val(ws.Cells(r, "P").Value)
angleRad = houseLong * pi / 180
' Внутренняя линия
x1 = centerX - rPlanetCircle * Cos(angleRad)
y1 = centerY + rPlanetCircle * Sin(angleRad)
x2 = centerX - rZodiacInner * Cos(angleRad)
y2 = centerY + rZodiacInner * Sin(angleRad)
Set houseLineInner = ws.Shapes.AddLine(x1, y1, x2, y2)
' Внешняя линия
x3 = centerX - rOuter * Cos(angleRad)
y3 = centerY + rOuter * Sin(angleRad)
Dim currentExt As Double
Dim houseIndex As Long
houseIndex = r - 1 ' Строка 2 = 1-й дом (ASC)
' Если это Асцендент (1-й дом), делаем его длиннее
If houseIndex = 1 Then currentExt = rAscExt Else currentExt = rHouseExt
x4 = centerX - currentExt * Cos(angleRad)
y4 = centerY + currentExt * Sin(angleRad)
Set houseLineOuter = ws.Shapes.AddLine(x3, y3, x4, y4)
' Стилизация базовых линий
houseLineInner.Line.ForeColor.RGB = RGB(120, 120, 120)
houseLineOuter.Line.ForeColor.RGB = RGB(120, 120, 120)
houseLineInner.Line.Weight = 1
houseLineOuter.Line.Weight = 1
' Выделение угловых домов
If houseIndex = 1 Or houseIndex = 4 Or houseIndex = 7 Or houseIndex = 10 Then
houseLineInner.Line.Weight = 1.75
houseLineOuter.Line.Weight = 1.75
houseLineInner.Line.ForeColor.RGB = RGB(40, 40, 40)
houseLineOuter.Line.ForeColor.RGB = RGB(40, 40, 40)
End If
End If
Next r
End Sub
Этот макрос берет список планет из столбцов A и B.
столбцы R, S и T -настройка аспектного блока
R - вид аспекта в десятичном формате, например 152,48
S - орбис
T - цвет линии аспекта
Шестнадцатеричный HEX-код (текст вроде #FF0000).
Если в ячейке возникнет ошибка или пустота, макрос по умолчанию покрасит линию аспекта в нейтральный черный цвет.
## Код макроса VBA для отрисовки аспектов
Код:
Sub DrawAstrologyAspects()
Dim ws As Worksheet: Set ws = ActiveSheet
' 1. Геометрический центр и радиус (линии аспектов соединяют точки планет на rPlanetCircle)
Dim centerX As Double, centerY As Double, rPlanetCircle As Double
centerX = 400: centerY = 260: rPlanetCircle = 135
Dim pi As Double: pi = 3.14159265358979
' 2. Читаем массив РЕАЛЬНЫХ ПЛАНЕТ с листа (Столбцы A и B)
Dim lastRowPlanets As Long
lastRowPlanets = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
If lastRowPlanets < 2 Then MsgBox "Нет планет для аспектирования!", vbExclamation: Exit Sub
Dim pCount As Long: pCount = lastRowPlanets - 1
ReDim pNames(1 To pCount) As String
ReDim pLongs(1 To pCount) As Double
Dim r As Long, pIdx As Long: pIdx = 1
For r = 2 To lastRowPlanets
If ws.Cells(r, 1).Value <> "" Then
pNames(pIdx) = ws.Cells(r, 1).Value
pLongs(pIdx) = Val(ws.Cells(r, 2).Value)
pIdx = pIdx + 1
End If
Next r
pCount = pIdx - 1
' 3. Читаем массив ИССЛЕДУЕМЫХ АСПЕКТОВ (Столбцы R, S, T)
Dim lastRowAspects As Long
lastRowAspects = ws.Cells(ws.Rows.count, "R").End(xlUp).Row
If lastRowAspects < 2 Then
MsgBox "Таблица исследуемых аспектов (в столбце R) пуста!", vbInformation
Exit Sub
End If
Dim aCount As Long: aCount = lastRowAspects - 1
ReDim targetAngles(1 To aCount) As Double
ReDim orbisValues(1 To aCount) As Double
ReDim aspectColors(1 To aCount) As Long
Dim aIdx As Long: aIdx = 1
Dim hexColor As String, cleanHex As String
Dim rVal As Long, gVal As Long, bVal As Long
For r = 2 To lastRowAspects
If ws.Cells(r, "R").Value <> "" And IsNumeric(ws.Cells(r, "R").Value) Then
targetAngles(aIdx) = Abs(Val(ws.Cells(r, "R").Value))
orbisValues(aIdx) = Abs(Val(ws.Cells(r, "S").Value))
' Парсинг цвета из HEX формата (#XXXXXX) в столбце T
hexColor = Trim(CStr(ws.Cells(r, "T").Value))
cleanHex = Replace(hexColor, "#", "")
' Если HEX-код валидный (6 символов), переводим его в RGB
If Len(cleanHex) = 6 Then
On Error Resume Next
rVal = CInt("&H" & Mid(cleanHex, 1, 2))
gVal = CInt("&H" & Mid(cleanHex, 3, 2))
bVal = CInt("&H" & Mid(cleanHex, 5, 2))
aspectColors(aIdx) = RGB(rVal, gVal, bVal)
On Error GoTo 0
Else
' Цвет по умолчанию, если формат нарушен — черный
aspectColors(aIdx) = RGB(0, 0, 0)
End If
aIdx = aIdx + 1
End If
Next r
aCount = aIdx - 1
' 4. МАТЕМАТИЧЕСКИЙ АНАЛИЗ ПАР ПЛАНЕТ
Dim i As Long, j As Long, k As Long
Dim lon1 As Double, lon2 As Double, rawDiff As Double, actualAspect As Double
Dim rad1 As Double, rad2 As Double
Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
Dim aspectLine As Shape
Dim matchFound As Boolean
' Перебираем каждую уникальную пару планет (комбинаторика без повторов)
For i = 1 To pCount - 1
For j = i + 1 To pCount
lon1 = pLongs(i)
lon2 = pLongs(j)
' Считаем кратчайшее дуговое расстояние на сфере (от 0 до 180 градусов)
rawDiff = Abs(lon1 - lon2)
If rawDiff > 180 Then
actualAspect = 360 - rawDiff
Else
actualAspect = rawDiff
End If
' Сверяем полученное расстояние со списком искомых аспектов
For k = 1 To aCount
' Условие попадания в орбис: | Факт - План | <= Орбис
If Abs(actualAspect - targetAngles(k)) <= orbisValues(k) Then
' Вычисляем экранные координаты планет-участников
rad1 = lon1 * pi / 180
rad2 = lon2 * pi / 180
x1 = centerX - rPlanetCircle * Cos(rad1)
y1 = centerY + rPlanetCircle * Sin(rad1)
x2 = centerX - rPlanetCircle * Cos(rad2)
y2 = centerY + rPlanetCircle * Sin(rad2)
' Чертим линию аспекта внутри центрального круга
Set aspectLine = ws.Shapes.AddLine(x1, y1, x2, y2)
' Стилизуем линию цветом из таблицы Т
With aspectLine.Line
.ForeColor.RGB = aspectColors(k)
.Weight = 1.25
' Если орбис очень точный (меньше 0.5 градусов), можно выделить жирнее
If Abs(actualAspect - targetAngles(k)) < 0.3 Then .Weight = 2
End With
matchFound = True
End If
Next k
Next j
Next i
End Sub
--------------------------------
Последний раз редактировалось Les, 22.08.2026 в 05:13.
как сделать так, чтобы макросы запускались автоматически, при изменении расчетной даты?
Если время в таблицу попадает автоматически, то можно использовать событие пересчета листа.
Worksheet_Calculate будет запускать построение космограммы при любом изменении любой формулы на этом листе. Если таблица большая, это может вызвать кратковременные зависания!!
## Пошаговая инструкция, куда вставить код:
1. Откройте редактор VBA.
2. В левой колонке (окно Project Explorer) найдите вашу рабочую книгу и дважды кликните по названию листа, на котором находится ваша таблица (например, Лист1 или Sheet1).
3. Важно: Не создавайте новый стандартный модуль, код должен находиться именно внутри самого листа!
4. В открывшееся пустое правое окно вставьте следующий код:
Код:
Private Sub Worksheet_Calculate()
' Это событие не умеет определять, какая конкретно ячейка изменилась,
' поэтому оно срабатывает при ЛЮБОМ пересчете формул на этом листе.
On Error GoTo CleanExit
' Отключаем события, чтобы макрос сам не вызвал повторный пересчет
Application.EnableEvents = False
Application.ScreenUpdating = False
' Запуск ваших макросов
Call DrawAstrologyChart_Final
Call DrawAstrologyHouses
Call DrawAstrologyAspects
CleanExit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
----------------------------------
Последний раз редактировалось Les, 22.08.2026 в 05:29.
Поддержу тему. Excel чрезвычайно мощная штука для астрологических рассчетов, с его помощью вы можете не сдерживать свою фантазию и получать то, что не покажет ни один астропроцессор.
Но для этого надо загрузить в Excel библиотеку рассчета швейцарских эфемерид. В свое время я их брал где здесь на ARGO.
А дальше вы просто сообщаете ИИ как выглядит обращение к функции вычисления юлианской даты JDAY и рассчета планет и куспидов PLC и дело в шляпе - ИИ напишет любой код.
Кстати рисунок можно выводить не только на листе Эксель. VBA позволяет работать с формами, и есть специальные графические элементы. Можно и на форме рисовать, а можно и в графическом элементе. Только надо код писать.
предыдущий вариант заточен под ручной ввод времени
чтобы сделать изменение времени кнопками (формы excel, счетчики)
надо
1) в макросе DrawAstrologyChart вместо
Dim shp As Shape
For Each shp In ws.Shapes
shp.Delete
Next shp
заменить на
Код:
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
' Проверяем тип объекта.
' Тип 8 — это элементы управления формы (счетчики, кнопки). Их мы НЕ удаляем!
If shp.Type <> 8 Then
shp.Delete
End If
Next shp
2) затем с листа удаляем весь код Private Sub Worksheet_Calculate
3) создаем один общий макрос для запуска
Открываем стандартный модуль (где находится наш основной макрос DrawAstrologyChart) и в самом низу добавлем этот код. Он будет служить «пультом управления» для всех счетчиков:
Код:
Sub RunOnSpinnerClick()
' Этот макрос будет запускаться каждый раз, когда вы кликаете на любой счетчик
On Error GoTo CleanExit
Application.ScreenUpdating = False
Application.EnableEvents = False
' Запуск построения вашей космограммы
Call DrawAstrologyChart_Final
' Call DrawAstrologyHouses
' Call DrawAstrologyAspects_Filtered
CleanExit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
затем идем на страницу, создаем счетчики, и назначаем каждому (год, месяц, день и тд) этот макрос Sub RunOnSpinnerClick
пришлось полностью переделать аспектный блок
были проблемы с отрисовкой и маленькими орбисами аспектов
добавил разделение отображаемых аспектов на сходящиеся и расходящиеся
макрос берет данные из столбцов A (обозначение планеты), B (долгота) и AA (скорость)
первая строка не учитывается
данные по скорости вынес за пределы видимого поля листа, чтоб не занимать место,
скорость нужна для определения вида аспекта сход/расход
ячейки U2 и V2 для флагов "сходящиеся" и "расходящиеся" соответственно
текст в них может быть любой
если обе ячейки пусты или заняты, отрисуются все аспекты
Код:
Sub DrawAstrologyAspects()
Dim ws As Worksheet
Set ws = ActiveSheet ' Универсально работает с текущим активным листом
' 1. Удаление старых линий аспектов
Dim shp As Shape
For Each shp In ws.Shapes
If InStr(shp.Name, "Aspect_") = 1 Then shp.Delete
Next shp
' 2. Чтение флагов фильтрации из ячеек U2 и V2
Dim showConverging As Boolean
Dim showDiverging As Boolean
Dim flagU As String, flagV As String
flagU = Trim(CStr(ws.Range("U2").Value))
flagV = Trim(CStr(ws.Range("V2").Value))
' Если обе заполнены или обе пусты — показываем всё
If (flagU <> "" And flagV <> "") Or (flagU = "" And flagV = "") Then
showConverging = True
showDiverging = True
Else
showConverging = (flagU <> "")
showDiverging = (flagV <> "")
End If
' 3. Геометрические параметры карты
Dim centerX As Double, centerY As Double, rPlanetCircle As Double
centerX = 400: centerY = 260: rPlanetCircle = 135
Dim pi As Double: pi = 3.14159265358979
' 4. Чтение данных планет (Координаты и Скорости)
Dim lastRowPlanets As Long
lastRowPlanets = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If lastRowPlanets < 2 Then Exit Sub
Dim pCount As Long: pCount = 0
Dim r As Long
For r = 2 To lastRowPlanets
If ws.Cells(r, 1).Value <> "" And IsNumeric(ws.Cells(r, 2).Value) Then
pCount = pCount + 1
End If
Next r
If pCount < 2 Then Exit Sub
ReDim pNames(1 To pCount) As String
ReDim pLongs(1 To pCount) As Double
ReDim pSpeeds(1 To pCount) As Double
Dim pIdx As Long: pIdx = 1
For r = 2 To lastRowPlanets
If ws.Cells(r, 1).Value <> "" And IsNumeric(ws.Cells(r, 2).Value) Then
pNames(pIdx) = ws.Cells(r, 1).Value
pLongs(pIdx) = CDbl(ws.Cells(r, 2).Value)
' Считываем скорость из скрытого столбца AA
If IsNumeric(ws.Cells(r, "AA").Value) Then
pSpeeds(pIdx) = CDbl(ws.Cells(r, "AA").Value)
Else
pSpeeds(pIdx) = 0#
End If
pIdx = pIdx + 1
End If
Next r
pCount = pIdx - 1
' 5. Чтение таблицы исследуемых аспектов (Столбцы R, S, T)
Dim lastRowAspects As Long
lastRowAspects = ws.Cells(ws.Rows.Count, "R").End(xlUp).Row
If lastRowAspects < 2 Then Exit Sub
Dim aCount As Long: aCount = 0
For r = 2 To lastRowAspects
If ws.Cells(r, "R").Value <> "" And IsNumeric(ws.Cells(r, "R").Value) Then aCount = aCount + 1
Next r
If aCount = 0 Then Exit Sub
ReDim targetAngles(1 To aCount) As Double
ReDim orbisValues(1 To aCount) As Double
ReDim aspectColors(1 To aCount) As Long
Dim aIdx As Long: aIdx = 1
Dim hexColor As String, cleanHex As String
Dim rVal As Long, gVal As Long, bVal As Long
For r = 2 To lastRowAspects
If ws.Cells(r, "R").Value <> "" And IsNumeric(ws.Cells(r, "R").Value) Then
targetAngles(aIdx) = Abs(CDbl(ws.Cells(r, "R").Value))
orbisValues(aIdx) = Abs(CDbl(ws.Cells(r, "S").Value))
hexColor = Trim(CStr(ws.Cells(r, "T").Value))
cleanHex = Replace(hexColor, "#", "")
If Len(cleanHex) = 6 Then
On Error Resume Next
rVal = CInt("&H" & Mid(cleanHex, 1, 2))
gVal = CInt("&H" & Mid(cleanHex, 3, 2))
bVal = CInt("&H" & Mid(cleanHex, 5, 2))
aspectColors(aIdx) = RGB(rVal, gVal, bVal)
On Error GoTo 0
Else
aspectColors(aIdx) = RGB(0, 0, 0)
End If
aIdx = aIdx + 1
End If
Next r
aCount = aIdx - 1
' 6. Математический анализ пар планет с АДАПТИВНЫМ ШАГОМ ВРЕМЕНИ
Dim i As Long, j As Long, k As Long
Dim lon1 As Double, lon2 As Double, rawDiff As Double, actualAspect As Double
Dim speed1 As Double, speed2 As Double
Dim rad1 As Double, rad2 As Double
Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
Dim aspectLine As Shape
Dim futureLon1 As Double, futureLon2 As Double
Dim futureRawDiff As Double, futureAspect As Double
' Переменные для адаптивного шага
Dim relSpeed As Double
Dim timeStep As Double
Dim curDistToTarget As Double, futDistToTarget As Double
Dim isApplying As Boolean
Dim skipAspect As Boolean
For i = 1 To pCount - 1
For j = i + 1 To pCount
Dim matchFoundInOrbis As Boolean
matchFoundInOrbis = False
lon1 = pLongs(i)
lon2 = pLongs(j)
speed1 = pSpeeds(i)
speed2 = pSpeeds(j)
' Кратчайшее текущее расстояние на окружности
rawDiff = Abs(lon1 - lon2)
If rawDiff > 180 Then actualAspect = 360# - rawDiff Else actualAspect = rawDiff
' Предварительно проверяем, образует ли эта пара хоть какой-то аспект из таблицы
' чтобы зря не вычислять динамику времени
For k = 1 To aCount
If Abs(actualAspect - targetAngles(k)) <= orbisValues(k) Then
matchFoundInOrbis = True
Exit For
End If
Next k
' Если аспект найден, рассчитываем сходимость с адаптивным шагом
If matchFoundInOrbis Then
' Вычисляем относительную скорость изменения дуги между планетами
relSpeed = Abs(speed2 - speed1)
' Рассчитываем индивидуальный временной шаг:
' Нам нужно, чтобы за этот шаг взаимное расстояние изменилось ровно на 0.0001°
If relSpeed > 0.00001 Then
timeStep = 0.0001 / relSpeed
' Ставим жесткие защитные лимиты на шаг:
If timeStep < 0.00001 Then timeStep = 0.00001 ' Защита от слишком быстрого шага (Луна)
If timeStep > 0.5 Then timeStep = 0.5 ' Защита от слишком огромного шага (стоянки)
Else
' Если скорости планет абсолютно равны или они стоят — ставим стандартный шаг
timeStep = 0.01
End If
' Моделируем индивидуальный шаг вперед во времени
futureLon1 = lon1 + (speed1 * timeStep)
futureLon2 = lon2 + (speed2 * timeStep)
' Удержание координат в пределах [0; 360)
futureLon1 = futureLon1 - (Int(futureLon1 / 360#) * 360#)
futureLon2 = futureLon2 - (Int(futureLon2 / 360#) * 360#)
If futureLon1 < 0 Then futureLon1 = futureLon1 + 360#
If futureLon2 < 0 Then futureLon2 = futureLon2 + 360#
' Будущее кратчайшее расстояние
futureRawDiff = Abs(futureLon1 - futureLon2)
If futureRawDiff > 180 Then futureAspect = 360# - futureRawDiff Else futureAspect = futureRawDiff
' Повторно проходим по аспектам для фильтрации и отрисовки
For k = 1 To aCount
If Abs(actualAspect - targetAngles(k)) <= orbisValues(k) Then
' СХОДИМОСТЬ: тренд изменения отклонения до точного аспекта
curDistToTarget = Abs(actualAspect - targetAngles(k))
futDistToTarget = Abs(futureAspect - targetAngles(k))
If futDistToTarget < curDistToTarget Then
isApplying = True
Else
isApplying = False
End If
' Фильтрация
skipAspect = False
If isApplying And Not showConverging Then skipAspect = True
If Not isApplying And Not showDiverging Then skipAspect = True
' Рисование
If Not skipAspect Then
rad1 = lon1 * pi / 180#
rad2 = lon2 * pi / 180#
x1 = centerX - rPlanetCircle * Cos(rad1)
y1 = centerY + rPlanetCircle * Sin(rad1)
x2 = centerX - rPlanetCircle * Cos(rad2)
y2 = centerY + rPlanetCircle * Sin(rad2)
Set aspectLine = ws.Shapes.AddLine(x1, y1, x2, y2)
aspectLine.Name = "Aspect_" & pNames(i) & "_" & pNames(j)
With aspectLine.Line
.ForeColor.RGB = aspectColors(k)
.Weight = 1.25
.DashStyle = msoLineSolid
End With
End If
End If
Next k
End If
Next j
Next i
End Sub
этот вариант защищен от эффекта «зависания» медленных планет и исключает «проскакивание» быстрых, хотя все может быть...
Последний раз редактировалось Les, 24.08.2026 в 05:53.
вот как сейчас выглядит лист
в левом верхнем углу формула для пересчета юлианской даты обратно в формат ДД ММ ГГГ ЧЧ ММ СС
Библиотека Swiss Ephemeris содержит встроенную функцию swe_revjul. Она выполняет строго обратную задачу: принимает дробное число Юлианской даты (JD) и раскладывает его на исходный год, месяц, день и дробный час. [1, 2]
Поскольку Excel 2000 (как и современные версии) физически не поддерживает даты ранее 1 января 1900 года, решением является сборка и возврат даты в текстовом формате ДД.ММ.ГГГГ ЧЧ:ММ:СС. В таком виде Excel не будет пытаться превратить её в своё внутреннее число и корректно отобразит любой исторический год (даже до нашей эры с минусом).
Код:
Public Function RevJDay(ByVal JD As Double, Optional ByVal GregFlg As Integer) As String' Переводит Юлианскую дату обратно в формат ДД.ММ.ГГГГ ЧЧ:ММ:СС' Поддерживает любые исторические даты (включая древние и до 1900 года)' JD = Юлианская дата' GregFlg = 1 для Григорианского календаря (по умолчанию), 0 для Юлианского
Dim year As Long
Dim month As Long
Dim day As Long
Dim hourDouble As Double
Dim hourInt As Integer
Dim minInt As Integer
Dim secDouble As Double
Dim secInt As Integer
Dim sDay As String, sMonth As String, sYear As String
Dim sHour As String, sMin As String, sSec As String
' Если флаг календаря не указан, используем Григорианский по умолчанию
If IsMissing(GregFlg) Or GregFlg = 0 Then GregFlg = 1
' Вызываем функцию из swedll32.dll
' Внимание: добавляем микро-сдвиг 0.0000001 для защиты от погрешности округления Double
Call swe_revjul(JD + 0.0000001, GregFlg, year, month, day, hourDouble)
' Разбираем дробный час (hourDouble) на Часы, Минуты и Секунды
hourInt = Fix(hourDouble)
minInt = Fix((hourDouble - hourInt) * 60)
secDouble = ((hourDouble - hourInt) * 60 - minInt) * 60
secInt = Round(secDouble)
' Корректировка переполнения секунд при округлении
If secInt >= 60 Then
secInt = 0
minInt = minInt + 1
End If
If minInt >= 60 Then
minInt = 0
hourInt = hourInt + 1
End If
' Форматируем текстовые составляющие с ведущими нулями
sDay = Right$("0" & day, 2)
sMonth = Right$("0" & month, 2)
sYear = Format$(year, "0000") ' Корректно отобразит даже 4-й или 500-й год
sHour = Right$("0" & hourInt, 2)
sMin = Right$("0" & minInt, 2)
sSec = Right$("0" & secInt, 2)
' Собираем финальную текстовую строку для ячейки Excel
RevJDay = sDay & "." & sMonth & "." & sYear & " " & sHour & ":" & sMin & ":" & sSec
End Function
-----------------
Последний раз редактировалось Les, 24.08.2026 в 06:12.
Превращаем Excel в астропроцессор
Линейный вид
