В Excel нет хордовой диаграммы. Но если вы — системный аналитик с VBA в руках, это не проблема, а вызов.
В этой статье я покажу, как с нуля создать кастомную визуализацию связей между данными: расчёты, тригонометрия, работа с формами и графика — всё на чистом VBA.
Не Power BI. Не D3.js. Просто Excel, логика и немного кода.
Соглашение
Здесь и далее я не буду использовать реальные данные той предметной области, в которой я работаю, а также не буду называть Компанию, и поэтому мы будем работать в рамках вымышленного Хлебозавода.
Допустим также, у нас есть веб-приложение, есть БД (реализованная на PostgreSQL).
С чего всё началось?
В качестве системного аналитика я столкнулась с необходимостью наглядной визуализации связей между сущностями. В нашем веб-приложении пользователи могут просматривать разные отчёты. Так вот, мне, как системному аналитику, необходимо обеспечить такой наглядный способ увидеть какие атрибуты модели, описанные в БД, имеют связь с отчётами.
Для чего это нужно? Да хотя бы для того, чтобы понимать, на каких витринах отчётов отразятся любые изменения какой-либо сущности, и, соответственно, в какие статьи в Confluence нужно внести соответствующие правки.
Внесли правки в одну статью по атрибуту? Найдите все статьи, где этот же атрибут задействован и внесите правки в них! Но вместо поиска можно использовать наглядное представление связей! И вот тут нам на помощь и приходит хордовая круговая диаграмма и VBA!
Приступаем к работе!
Сперва - идея и краткое ТЗ. Вот что мы хотим видеть:
- Связи между сущностями мы хотим представлять в матрице, то есть таблице, где при наличии связи между сущностью и отчётом мы ставим "да".
- Также мы соглашаемся с тем, что у нас будет четыре группы атрибутов.
- Кроме того, нам бы хотелось, чтобы диаграмма рисовалась на отдельном листе, где также должна присутствовать Легенда (чтобы пользователь мог не только видеть и изменять цвет Групп атрибутов, но и выбирать атрибуты какого типа вообще выводить), а также настройки отрисовки Диаграммы - диаметр круга, толщина линий.
- Ну и так как отчётов у нас довольно много (19 штук), то пусть будет фильтр - возможность выбрать один какой-то отчёт для построения диаграммы связей только с ним одним.
- При клике на атрибут или сущность (так мы называть будет отчёты) нам бы хотелось, чтобы взаимосвязанные объекты окрашивались бы цветом, а все не связанные - делались бы полупрозрачными.
- А ещё мы хотим, чтобы при этом на экране показывалось окошко с перечнем связанных объектов.
- Т.к. мы должны получать информацию о связях между атрибутами и сущностями, то условимся, что будем записывать эту информацию как: "[текст атрибута/сущности] Связь: [строки с текстом связанного атрибута/сущности]".
- При клике вне сущности - хотелось бы, чтобы раскраска всей диаграммы приводилась к исходному состоянию.
- Ну и само собой - чтобы нам не приходилось вручную удалять все фигуры и линии, а диаграмма каждый раз при перестройке "зачищалась" бы сперва.
Сразу сделаю замечание, что да - я иногда использую для ускорения выполнения работы ИИ. Так, для создания круговой хордовой диаграммы я использовала Qwen. Но надо понимать, что без реального опыта в программировании на VBA получить действительно хороший результат - трудно, потому что ИИ допускает ошибки в коде - и иногда весьма нетривиальные.
Поэтому здесь я использовала ИИ только для создания канвы и главным образом - для написания кода процедур и функций, непосредственно связанных с размещением текстовых полей по кругу, а также отрисовки кривых Безье.
Строим файл
Начнём с листа, на котором будет находиться диаграмма, легенда и настройки. Назовём этот лист Диаграмма связей. Размещаем на нём всё, что нужно:
Таблицу с группировкой называем group_colors
Таблицу с настройками диаграммы никак особенно не называем, но именуем ячейки в ней в столбце "Значение" следующим образом:
- радиус круга - diagram_radius
- центр по X - diagram_centerX
- центр по Y - diagram_centerY
- ширина прямоугольника сущности - box_width
- высота прямоугольника сущности - box_height
Кнопку отрисовки диаграммы называем btnBuildDIagram, а выпадающий список отчётов - cmbxEntities.
Теперь создаём лист с настройками связей сущностей и атрибутов:
Здесь всё просто и понятно из скриншота: в первом столбце идёт подстановка из таблицы group_colors из столбца с названиями категорий, во втором столбце - наименования атрибутов, а в первой строке, начиная с третьего столбца - идут наименования отчётов. Также из рисунка видно - там, где в ячейке стоит "да" - есть связь между атрибутом и отчётом.
Теперь мы готовы к работе и сохраняем файл с Поддержкой макросов - т.е. в формате *.xlsm.
Начинаем кодить!
Открываем редактор кода (Alt+F11) и создаём пользовательскую форму. Называем её frmTooltip. Добавим на неё текстовое поле, назовём его txtRelations.
Переходим в модуль листа "Диаграмма связей". В самом верху пишем:
Dim tooltip As Object ' TooltipForm
Здесь мы объявили переменную, которая будет содержать в себе экземпляр нашей экранной формы. Это необходимо, чтобы отображать каждый раз новый экземпляр формы, когда мы кликаем на сущность, атрибут или связь.
Теперь напишем код, который позволяет нам "освежать" список доступных для выбора в фильтре отчёта:
Private Sub Worksheet_Activate()
Dim startCol As Integer, col As Integer
Dim dataSheet As Worksheet
Set dataSheet = ThisWorkbook.Sheets("Атрибуты актива и АСО")
startCol = 3
cmbxEntities.Clear
endCol = dataSheet.Cells(1, dataSheet.Columns.Count).End(xlToLeft).Column
For col = startCol To endCol
cmbxEntities.AddItem dataSheet.Cells(1, col).value
Next
End Sub
В коде выше - мы сперва очищаем выпадающий список. Затем, проходим по заголовкам столбцов, начиная с третьего, на листе "Атрибуты актива и АСО" (у Вас может быть другое наименование листа) и все считанные наименования записываем в выпадающий список.
Добавляем код сброса отображения всех фигур на листе (процедуру мы запишем позже):
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Сброс
Call ResetAllShapes
End Sub
В коде выше мы просто вызываем сброс до исходных стилей всех фигур на листе. Ведь мы помним, что при клике на сущность или атрибут - все взаимосвязанные с ними объекты окрашиваются, а остальные - становятся полупрозрачными. Так вот чтобы вернуть всё в исходное состояние мы и вызываем здесь эту процедуру - при клике в любом месте листа.
Далее - нам понадобится ряд вспомогательных функций и процедур - их код мы размещаем в отдельном модуле.
Функция нахождения минимального из двух данных значений:
Function Min(a As Double, b As Double) As Double
If a < b Then Min = a Else Min = b
End Function
Остановимся на минуту и подумаем - что есть у наших будущих фигур (текстовых блоков)? Есть у них имена (Name) и текст, написанный внутри их (TextFrame.Characters.text). В каком виде мы будем хранить в оперативной памяти информацию о наших фигурах? Я предлагаю использовать для этого словарь.
Что представляет собой словарь (Dictionary) в VBA Excel? Это набор пар ключ-значение. Ключом в нашем случае может служить хоть имя фигуры, хоть текст, размещённый внутри её.
Кстати о тексте. Как бы нам так определить для раскраски какой текстовый блок относится к какой группировке? Здесь я решила использовать префикс в виде наименования группировки, отделяемый от основного наименования атрибута точкой. Вот, как это выглядит на практике:
Для чего нам хранить в оперативной памяти все наши фигуры, да ещё знать их текст и имена? Да за тем, чтобы делать раскраску! Ведь нам нужно будет в цикле пробегать по всем фигурам, находить взаимосвязанные, перекрашивать их.
С этой целью я создала глобальную (Public) коллекцию entitiesAndRelations в отдельном модуле, где мы размещаем функции и процедуры:
Public entitiesAndRelations As Object
Ключом в этой коллекции служит наименование (Name) фигуры, а значением является опять же коллекция, содержащая в себе текст (TextFrame.Characters.text) связанных с данной фигур. Когда мы кликаем мышью по фигуре - мы знаем её имя, и по нему можем в коллекции найти все связанные фигуры - вернее - их текст. Затем - пробежавшись по всем фигурам мы раскрасим только те, что содержат текст "связанных фигур", а остальные сделаем полупрозрачными. Да здесь можно было положить в коллекцию имена фигур, а не текст, но мне захотелось сделать так, как сделано.
Итак, продолжаем наполнять наш модуль дополнительными функциями и процедурами:
Function GetEntitiesFromShape(shp As Shape) As String()
Dim result(0 To 1) As String
Dim tip As String
tip = shp.AlternativeText
If InStr(tip, "Связь:") Then
Dim parts
parts = Split(Split(tip, "Связь:")(1), "?")
If UBound(parts) >= 1 Then
result(0) = Trim(parts(0))
result(1) = Trim(parts(1))
GetEntitiesFromShape = result
Exit Function
End If
End If
result(0) = ""
result(1) = ""
GetEntitiesFromShape = result
End Function
Код выше - позволяет получить все связанные с данной сущности.
Function Contains(col As Collection, value As String) As Boolean
Dim i As Integer
For i = 1 To col.Count
If col(i) = value Then
Contains = True
Exit Function
End If
Next i
Contains = False
End Function
Код выше - просто проверка есть ли в коллекции элемент, значение которого равно искомому.
Sub ResetAllShapes()
Dim ws As Worksheet
Dim cindex As Integer
Dim found As Boolean
Set ws = ThisWorkbook.Sheets("Диаграмма связей")
Dim tblGroupSettings As ListObject
Set tblGroupSettings = ws.ListObjects("group_colors")
Dim shp As Shape
For Each shp In ws.Shapes
If left(shp.Name, 4) = "Net_" Then
found = False
If shp.Type = msoTextBox Then
For cindex = 2 To tblGroupSettings.Range.Rows.Count
If VBA.InStr(VBA.CStr(shp.TextFrame.Characters.text), tblGroupSettings.Range(cindex, 1).value & ".") <> 0 Then
shp.Fill.ForeColor.rgb = tblGroupSettings.Range(cindex, 2).Interior.Color
found = True
Exit For
End If
Next
If found = False Then
shp.Fill.ForeColor.rgb = rgb(255, 255, 255)
End If
shp.Line.Weight = 1
shp.TextFrame.Characters.Font.Color = rgb(0, 0, 0)
shp.Fill.Transparency = 0
ElseIf shp.Type = msoFreeform Or shp.Type = msoLine Then
shp.Line.Transparency = 0
shp.Line.Weight = 1
End If
End If
Next shp
End Sub
Уже говорили об этой процедуре - здесь происходит сброс раскраски всех фигур до настроек, заданных пользователем. Запускается при клике на любую ячейку на листе с диаграммой.
Function GetRelatedEntities(shpName As String, ws As Worksheet) As Collection
Dim key As Variant, relShapeName As String
Dim keyRelated As String
Dim result As Collection
Dim index As Integer
Dim keyText As String
Dim relatedShapeName As String
Set result = New Collection
For Each key In entitiesAndRelations.keys
If key = shpName Then
keyText = ws.Shapes(key).TextFrame.Characters.text
For index = 1 To entitiesAndRelations(key).Count
relatedShapeName = entitiesAndRelations(key).item(index)
result.Add ws.Shapes(relatedShapeName).TextFrame.Characters.text
Next
Exit For
End If
Next
Set GetRelatedEntities = result
End Function
Код выше - как раз предназначен для получения коллекции связанных с данной сущностей - в виде набора "текстов" в них содержащихся.
Теперь переходим к раскраске.
Sub HighlightRelatedShapes(clickedShp As Shape, ws As Worksheet)
' Сброс
ResetAllShapes
' Определяем сущность
Dim entityName As String
If left(clickedShp.Name, 9) = "Net_Node_" Then
entityName = clickedShp.TextFrame.Characters.text
ElseIf left(clickedShp.Name, 8) = "Net_Arc_" Then
Dim parts
parts = Split(Split(clickedShp.AlternativeText, "Связь:")(1), "?")
If UBound(parts) >= 1 Then
entityName = Trim(parts(0)) ' можно выбрать from или to
End If
Else
Exit Sub
End If
If entityName = "" Then Exit Sub
' Получаем связанные
Dim related As Collection
Set related = GetRelatedEntities(clickedShp.Name, ws)
' Применяем выделение
ApplyHighlight entityName, related, ws
End Sub
Код выше - применить раскраску. Из этой процедуры мы вызываем сперва сброс раскраски всех фигур, а затем - раскраску всех связанных с данной сущностей.
Sub ApplyHighlight(centerEntity As String, relatedEntities As Collection, ws As Worksheet)
Dim shp As Shape
' Цвета
Dim colorCenter As Long ' центр
Dim colorRelated As Long ' связанные
Dim colorOther As Long ' остальные
colorCenter = rgb(255, 215, 0) ' золотой
colorRelated = rgb(0, 0, 255) ' синий
colorOther = rgb(128, 128, 128) ' серый
' Перебираем все фигуры
For Each shp In ws.Shapes
If left(shp.Name, 4) = "Net_" Then
Dim isRelevant As Boolean
isRelevant = False
If left(shp.Name, 9) = "Net_Node_" Then
' Это блок
Dim nodeName As String
nodeName = shp.TextFrame.Characters.text
If nodeName = centerEntity Then
' Центральный узел
shp.Fill.ForeColor.rgb = colorCenter
shp.Fill.Transparency = 0.2
shp.Line.Weight = 2.5
isRelevant = True
Else
Dim i As Integer
On Error Resume Next
For i = 1 To relatedEntities.Count
If nodeName = relatedEntities(i) Then
shp.Fill.ForeColor.rgb = colorRelated
shp.Fill.Transparency = 0.3
shp.Line.Weight = 2
isRelevant = True
Exit For
End If
Next i
On Error GoTo 0
End If
ElseIf left(shp.Name, 8) = "Net_Arc_" Then
' Это линия - проверяем, связывает ли она relevant-узлы
Dim fromTo() As String
fromTo = GetEntitiesFromShape(shp)
If UBound(fromTo) = 1 Then
Dim from As String, t As String
from = fromTo(0)
t = fromTo(1)
If (from = centerEntity Or Contains(relatedEntities, from)) And _
(t = centerEntity Or Contains(relatedEntities, t)) Then
shp.Line.Weight = 2.2
shp.Line.ForeColor.rgb = rgb(0, 0, 0)
isRelevant = True
End If
End If
End If
' Если не relevant - делаем полупрозрачным
If Not isRelevant Then
If shp.Type = msoTextBox Then
shp.Fill.Transparency = 0.7
shp.Line.Transparency = 0.7
shp.TextFrame.Characters.Font.Color = rgb(150, 150, 150)
ElseIf shp.Type = msoFreeform Or shp.Type = msoLine Then
shp.Line.Transparency = 0.7
End If
End If
End If
Next shp
End Sub
Код выше - вот как раз здесь мы и производим раскраску (цвета можете менять по своему усмотрению) сущностей и атрибутов, делая полупрозрачными все не связанные. То есть вот так:
Теперь можем заняться выводом информации о связях:
Sub ShowTooltipForm(shp As Shape)
' Если форма уже открыта - закрываем
On Error Resume Next
Unload frmTooltip
On Error GoTo 0
' Создаём новую
Dim tooltip As New frmTooltip
' Текст из AlternativeText
Dim info As String
info = shp.AlternativeText
If info = "" Then info = "Нет информации"
tooltip.txtRelations.text = info
' Размеры
tooltip.txtRelations.width = 450
tooltip.txtRelations.height = 200
tooltip.width = tooltip.txtRelations.width + 20
tooltip.height = tooltip.txtRelations.height + 40
' Позиция: рядом с фигурой
Dim leftPos As Double, topPos As Double
leftPos = ActiveWindow.width / 2
topPos = ActiveWindow.height / 2
tooltip.StartUpPosition = 0 ' пользовательское
tooltip.left = leftPos
tooltip.top = topPos
Call tooltip.Show
End Sub
В коде выше мы показываем форму, а в ней - информацию о связях между выбранной пользователем сущностью/атрибутом с остальными сущностями/атрибутами.
Соберём всё воедино - настроим обработку клика:
Sub HandleClick()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Диаграмма связей")
Dim clickedShp As Shape
On Error Resume Next
Set clickedShp = ws.Shapes(Application.Caller)
On Error GoTo 0
If clickedShp Is Nothing Then Exit Sub
' === 1. СНАЧАЛА - выделяем связанные узлы ===
HighlightRelatedShapes clickedShp, ws
' === 2. ЗАТЕМ - показываем форму с информацией ===
ShowTooltipForm clickedShp
End Sub
Процедуру, код которой размещён выше, мы установим в качестве макроса, запускаемого при клике по фигуре. Как видно из листинга - сперва мы выделим цветом связанные сущности/атрибуты, а после этого покажем окошко с информацией о связях. То есть вот так:
Сразу отвечу на возможный вопрос о том, почему мы не использовали MsgBox. Потому что он блокирует перерисовку листа, а нам как раз хотелось бы сперва увидеть раскраску, а потом уже окошко с информацией. Поэтому использование формы стало идеальным решением.
Итак, вернёмся в модуль листа с диаграммой и разместим в нём следующую функцию:
Function GetEdgePoint(centerX As Double, centerY As Double, _
boxX As Double, boxY As Double, _
width As Double, height As Double, _
rotationDeg As Double, Optional inward As Boolean = False) As Variant
Dim result(1 To 2) As Double
' Вектор: от блока к центру (внутрь) или от центра к блоку (наружу)
Dim dx As Double, dy As Double
If inward Then
dx = centerX - boxX ' к центру ? внутренняя точка
dy = centerY - boxY
Else
dx = boxX - centerX ' от центра ? внешняя точка
dy = boxY - centerY
End If
' Нормализуем
Dim ln As Double
ln = Sqr(dx * dx + dy * dy)
If ln = 0 Then
result(1) = boxX
result(2) = boxY
GoTo ReturnResult
End If
dx = dx / ln
dy = dy / ln
Dim cx As Double, cy As Double
cx = boxX
cy = boxY
Dim hw As Double, hh As Double
hw = width / 2
hh = height / 2
Dim angleRad As Double
angleRad = -rotationDeg * Application.Pi() / 180
' Поворачиваем вектор в локальную систему
Dim dxr As Double, dyr As Double
dxr = dx * Cos(angleRad) - dy * Sin(angleRad)
dyr = dx * Sin(angleRad) + dy * Cos(angleRad)
' Находим пересечение луча с границей прямоугольника
Dim t As Double
t = 1000
If dxr > 0 Then t = Min(t, hw / dxr) ' правая
If dxr < 0 Then t = Min(t, -hw / dxr) ' левая
If dyr > 0 Then t = Min(t, hh / dyr) ' верх
If dyr < 0 Then t = Min(t, -hh / dyr) ' низ
If t < 0.001 Then t = 0.001
' Точка в локальных координатах
Dim lx As Double, ly As Double
lx = dxr * t
ly = dyr * t
' Обратный поворот
result(1) = cx + lx * Cos(-angleRad) - ly * Sin(-angleRad)
result(2) = cy + lx * Sin(-angleRad) + ly * Cos(-angleRad)
ReturnResult:
GetEdgePoint = result
End Function
Эта "хитрая" функция используется при рисовании кривых Безье - наших изумительных хорд в диаграмме!
Ну и теперь в "Режиме конструктора" дважды кликнем по кнопке btnBuildDiagram и вставим в процедуру обработки клика следующий код:
Private Sub btnBuildDiagram_Click()
Dim goalSheet As Worksheet
Set goalSheet = ThisWorkbook.Sheets("Диаграмма связей")
Dim dataSheet As Worksheet
Set dataSheet = ThisWorkbook.Sheets("Атрибуты актива и АСО")
Dim tblGroupSettings As ListObject
Set tblGroupSettings = goalSheet.ListObjects("group_colors")
Dim boxWidth As Double, boxHeight As Double
Dim lastRow As Integer
Dim shp As Shape
Dim i As Integer, j As Integer, n As Integer
Dim angle As Double, X As Double, Y As Double, r As Double, angleDeg As Double
Dim centerX As Double, centerY As Double
Dim entities As Object
Set entities = CreateObject("Scripting.Dictionary")
Set entitiesAndRelations = CreateObject("Scripting.Dictionary")
Dim shapesCoordinates As Object
Set shapesCoordinates = CreateObject("Scripting.Dictionary")
Dim cindex As Integer
Dim rowNum As Integer
Dim tmpKey As String
Dim pointAx As Double, pointAy As Double
Dim pointBx As Double, pointBy As Double
Dim arrCoordinates As Variant
Dim strLineInfo As String
Dim tmpShapeNameA As String, tmpShapeNameB As String
Dim found As Boolean
' Очистка старых фигур (с префиксом "Net_")
For Each shp In goalSheet.Shapes
If left(shp.Name, 4) = "Net_" Then shp.Delete
Next shp
' Считываем имена сущностей из строки 1 (столбцы B:E)
Dim startCol As Integer, endCol As Integer
startCol = 3 ' C
endCol = dataSheet.Cells(1, dataSheet.Columns.Count).End(xlToLeft).Column
lastRow = dataSheet.Range("A" & Rows.Count).End(xlUp).row
Dim col As Integer
Dim idx As Integer
idx = 0
If cmbxEntities.text = "" Then
For col = startCol To endCol
Dim key As String
key = Trim(dataSheet.Cells(1, col).value)
If key <> "" Then
entities(key) = idx
idx = idx + 1
End If
Next col
Else
entities(cmbxEntities.text) = idx
idx = idx + 1
End If
rowNum = 2
Do While rowNum < lastRow
For cindex = 2 To tblGroupSettings.Range.Rows.Count
If tblGroupSettings.Range(cindex, 1).value = dataSheet.Cells(rowNum, 1).value And _
tblGroupSettings.Range(cindex, 3).value = "да" Then
key = Trim(dataSheet.Cells(rowNum, 1).value) & "." & Trim(dataSheet.Cells(rowNum, 2).value)
If key <> "" And key <> "." Then
entities(key) = idx
idx = idx + 1
'cindex = cindex + 1
End If
End If
Next
rowNum = rowNum + 1
Loop
n = entities.Count
If n = 0 Then
MsgBox "Не найдено ни одной сущности!", vbExclamation
Exit Sub
End If
' Параметры круга
r = goalSheet.Range("diagram_radius").value
centerX = goalSheet.Range("diagram_centerX").value
centerY = goalSheet.Range("diagram_centerY").value
boxWidth = goalSheet.Range("box_width").value
boxHeight = goalSheet.Range("box_height").value
' Массив координат
Dim positions() As Double
ReDim positions(0 To n - 1, 1 To 2)
Dim entity As Variant
' Рисуем узлы по кругу с поворотом
For Each entity In entities.keys
i = entities(entity)
Set entitiesAndRelations(entity) = New Collection 'коллекция для хранения связанных сущностей
angleRad = 2 * Application.Pi() * i / n ' угол в радианах
angleDeg = angleRad * 180 / Application.Pi() ' в градусы
X = centerX + r * Cos(angleRad)
Y = centerY + r * Sin(angleRad)
' === ВАРИАНТ 1: текст по касательной (как подсолнух) ===
' Текст параллелен окружности
' rotationAngle = angleDeg + 90
' === ВАРИАНТ 2: текст радиально (смотрит из центра) ===
' Раскомментируй следующую строку, если хочешь "лучи"
rotationAngle = angleDeg
' Добавляем текстовое поле
For cindex = 2 To tblGroupSettings.Range.Rows.Count
If VBA.InStr(VBA.CStr(entity), tblGroupSettings.Range(cindex, 1).value) <> 0 Then
boxWidth = 150
boxHeight = 20
End If
Next
Set shp = goalSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, X - boxWidth / 2, Y - boxHeight / 2, boxWidth, boxHeight)
shp.TextFrame.Characters.text = entity
shp.TextFrame.HorizontalAlignment = xlCenter
shp.TextFrame.VerticalAlignment = xlCenter
shp.Name = "Net_Node_" & i
shp.Line.ForeColor.rgb = rgb(0, 0, 0)
shp.Fill.ForeColor.rgb = rgb(255, 255, 255)
For cindex = 2 To tblGroupSettings.Range.Rows.Count
If VBA.InStr(VBA.CStr(entity), tblGroupSettings.Range(cindex, 1).value) <> 0 Then
shp.Fill.ForeColor.rgb = tblGroupSettings.Range(cindex, 2).Interior.Color
End If
Next
' === ПОВОРОТ ===
' === Определяем, нужно ли переворачивать текст ===
Dim finalAngle As Double
'finalAngle = angleDeg + 90 ' +90 - чтобы текст был по касательной
' Если блок в левой половине круга - переворачиваем текст на 180°
If rotationAngle > 90 And rotationAngle < 270 Then
rotationAngle = rotationAngle + 180
End If
' Приводим к диапазон 0-360
If rotationAngle >= 360 Then finalAngle = rotationAngle - 360
If rotationAngle < 0 Then finalAngle = rotationAngle + 360
' Применяем поворот
shp.Rotation = rotationAngle
shp.AlternativeText = entity & VBA.vbNewLine & VBA.vbNewLine & "Связь:" & VBA.vbNewLine & VBA.vbNewLine
shp.OnAction = "HandleClick"
' Дополнительно: можно немного отодвинуть при больших углах
' (не обязательно, но помогает при длинных названиях)
positions(i, 1) = X
positions(i, 2) = Y
shapesCoordinates.Add entity, VBA.CStr(X) & ";" & VBA.CStr(Y) & ";" & VBA.CStr(rotationAngle) & ";" & VBA.CStr(boxWidth) & ";" & VBA.CStr(boxHeight) & ";" & shp.Name
Next entity
rowIdx = 0
' Рисуем связи
For Each entity In entities.keys
' ключ - искомый текст
If VBA.InStr(entity, ".") = 0 Then
' нашли сущность - не атрибут
arrCoordinates = VBA.Split(shapesCoordinates(entity), ";") ' получаем координаты сущности
pointAx = VBA.CDbl(arrCoordinates(0))
pointAy = VBA.CDbl(arrCoordinates(1))
angleDeg = VBA.CDbl(arrCoordinates(2))
boxWidth = VBA.CDbl(arrCoordinates(3))
boxHeight = VBA.CDbl(arrCoordinates(4))
tmpShapeNameA = VBA.CStr(arrCoordinates(5))
Set entitiesAndRelations(tmpShapeNameA) = New Collection
Dim pt1() As Double
pt1 = GetEdgePoint(centerX, centerY, _
pointAx, pointAy, _
boxWidth, boxHeight, _
angleDeg, True)
For col = startCol To endCol
' проходим по столбцам слева направо
If dataSheet.Cells(1, col).value = entity Then
' нашли искомую сущность
'Debug.Print (entity)
For rowNum = 2 To lastRow
If dataSheet.Cells(rowNum, col).value = "да" Then
tmpKey = Trim(dataSheet.Cells(rowNum, 1).value) & "." & Trim(dataSheet.Cells(rowNum, 2).value)
If shapesCoordinates.exists(tmpKey) = True Then
arrCoordinates = VBA.Split(shapesCoordinates(tmpKey), ";") ' получаем координаты сущности
pointBx = VBA.CDbl(arrCoordinates(0))
pointBy = VBA.CDbl(arrCoordinates(1))
angleDeg = VBA.CDbl(arrCoordinates(2))
boxWidth = VBA.CDbl(arrCoordinates(3))
boxHeight = VBA.CDbl(arrCoordinates(4))
tmpShapeNameB = VBA.CStr(arrCoordinates(5))
Dim pt2() As Double
pt2 = GetEdgePoint(centerX, centerY, _
pointBx, pointBy, _
boxWidth, boxHeight, _
angleDeg, True)
' === Векторы от точек к центру и дальше ===
Dim midX As Double, midY As Double
midX = centerX
midY = centerY
' Векторы от pt1 к центру и от центра к pt2
Dim dx1 As Double, dy1 As Double
dx1 = midX - pt1(1)
dy1 = midY - pt1(2)
Dim dx2 As Double, dy2 As Double
dx2 = pt2(1) - midX
dy2 = pt2(2) - midY
' Длина векторов
Dim len1 As Double, len2 As Double
len1 = Sqr(dx1 * dx1 + dy1 * dy1)
len2 = Sqr(dx2 * dx2 + dy2 * dy2)
' Нормализуем
If len1 > 0 Then
dx1 = dx1 / len1
dy1 = dy1 / len1
End If
If len2 > 0 Then
dx2 = dx2 / len2
dy2 = dy2 / len2
End If
' === Контрольные точки: чуть дальше за центром ===
Dim k As Double
k = 0.8 ' степень "протяжённости" кривой через центр
Dim ctrl1X As Double, ctrl1Y As Double
Dim ctrl2X As Double, ctrl2Y As Double
ctrl1X = midX + dx1 * (len1 * k)
ctrl1Y = midY + dy1 * (len1 * k)
ctrl2X = midX + dx2 * (len2 * k)
ctrl2Y = midY + dy2 * (len2 * k)
' === Массив точек для кривой Безье ===
Dim pts(1 To 4, 1 To 2) As Single
pts(1, 1) = pt1(1): pts(1, 2) = pt1(2) ' начальная точка
pts(2, 1) = ctrl1X: pts(2, 2) = ctrl1Y ' контрольная 1
pts(3, 1) = ctrl2X: pts(3, 2) = ctrl2Y ' контрольная 2
pts(4, 1) = pt2(1): pts(4, 2) = pt2(2) ' конечная точка
' Рисуем кривую
Set shp = goalSheet.Shapes.AddCurve(pts)
shp.Name = "Net_Arc_" & rowIdx
shp.Line.ForeColor.rgb = rgb(0, 0, 0)
shp.Line.Weight = 1.2
rowIdx = rowIdx + 1
strLineInfo = "Связь: " & VBA.vbNewLine & VBA.vbNewLine & VBA.CStr(tmpKey) & VBA.vbNewLine & " <-> " & VBA.vbNewLine & VBA.CStr(entity)
'Debug.Print (strLineInfo)
entitiesAndRelations(tmpShapeNameA).Add tmpShapeNameB
If entitiesAndRelations.exists(tmpShapeNameB) = False Then
Set entitiesAndRelations(tmpShapeNameB) = New Collection
End If
entitiesAndRelations(tmpShapeNameB).Add tmpShapeNameA
shp.OnAction = "HandleClick"
shp.AlternativeText = strLineInfo
' Прописываем связи в текстовые блоки:
goalSheet.Shapes(tmpShapeNameA).AlternativeText = goalSheet.Shapes(tmpShapeNameA).AlternativeText & tmpKey & VBA.vbNewLine
goalSheet.Shapes(tmpShapeNameB).AlternativeText = goalSheet.Shapes(tmpShapeNameB).AlternativeText & entity & VBA.vbNewLine
End If
End If
Next
End If
Next
End If
Next
MsgBox "Диаграмма построена! " & n & " сущностей, " & goalSheet.Shapes.Count - n & " связей.", vbInformation
End Sub
Что происходит в коде выше? Там мы заполняем коллекцию сущностей, о которой говорили выше - из таблице на листе с данными (матрица связей сущностей - помните?). Затем мы отрисовываем сущности и атрибуты по кругу, как лепестки подсолнуха, используя настройки, заданные пользователем (атрибуты будут закрашены согласно категории, к которой они относятся, а сущности останутся белыми; а ещё - сущности рисуются более крупными прямоугольниками). Ну и в конце - рисуем хорды - линии связей между сущностями, согласно матрице связей. Вот и всё! Осталось сохранить файл и нажать на кнопку "Построить диаграмму", чтобы увидеть результат!
Вся эта работа - от идеи до воплощения - заняла у меня два дня (с учётом отвлечения на другие задачи). Теперь у меня и коллег есть под рукой инструмент, который позволяет в любой момент узнать как атрибуты, записанные в БД, связаны с Отчётами - и всё это - в виде крутой круговой хордовой диаграммы в самом обычном Excel. И для того, чтобы моим коллегам внести правки в этот файл - им не нужно знать программирование - им достаточно внести правки в матрицу связей (включая добавление/удаление атрибутов/отчётов). А диаграмма строится одним нажатием кнопки.
Стоит отменить, что и фильтрация наша тоже работает! Вот, например, как будет выглядеть та же диаграмма, если выбрать всего один отчёт для построения:
Заключение
Что здесь стоило бы улучшить? Безусловно, чего не хватает - это обработчика ошибок! Также можно было бы сделать "зачистку" диаграммы (то есть полное удаление всех фигур и линий) при открытии файла и перестройку диаграммы (это нужно для наполнения словаря данными обо всех фигурах и их связях). Можно ещё добавить раскраску линий связей. Можно сделать более гибкой настройку размеров прямоугольников сущностей и атрибутов. Но в целом - уже на данном этапе мы имеем прекрасно работающий инструмент!
По ссылке можете просмотреть видео построения диаграммы: https://dzen.ru/video/watch/68bd1dd1d102e266d6272195?share_to=link