Chip 2004 April/CMCD0404.ISO/Software/Demo/conceptdraw/data1.cab/Samples__Basic/Solutions/Diagraming/CircleDiagram/CircleDiagram.cdb

Text File | 2004-02-13 | 31.6 KB | 633 lines

#IF Target_MacOS
    Const constrUserMenuName As String = "Fill Diagrams"
    Const constrFillFirstDiagram As String = "Fill First Diagram"
    Const constrFillSecondDiagram As String = "Fill Second Diagram"
    Const constrRefreshBothDiagrams As String = "Refresh Both Diagrams"
#ELSE
    Const constrUserMenuName As String = "Fill Di&agrams"
    Const constrFillFirstDiagram As String = "Fill &First Diagram"
    Const constrFillSecondDiagram As String = "Fill &Second Diagram"
    Const constrRefreshBothDiagrams As String = "&Refresh Both Diagrams"
#ENDIF


'Символ, служащий разделителем между полями.
Const constrCharSeparator As String = ";"

'Массив, содержащий номера столбцов, в которых записано имя филиала, в файле данных каждого из типов.
Dim aiNameFieldPos(1) As Integer
'Массив, содержащий номера столбцов, в которых записана прибыль филиала за интересующий период, в файле данных одного из типов.
Dim aiValueFieldPos(1) As Integer
'Инициализация этих массивов.
aiNameFieldPos(0)=1
aiValueFieldPos(0)=9
aiNameFieldPos(1)=2
aiValueFieldPos(1)=3

'Максимальное количество строк в файле данных, которое будет обрабатывать скрипт.
Const conintMaxProcessingStrings As Integer = 10

'Ширина объекта, содержащего легенду диаграммы.
Const condblLegendWidth As Double = 600

'Индекс типа диаграммы, которая будет создана при данном вызове функции построения.
Dim intDiagramIndex As Integer
'Флаг, показывающий использовать ли библиотечные объекты при построении диаграмм.
Dim bUseLibObjects As Boolean

'Массивы, содержащие данные о работе филиалов.
'Имена филиалов.
Dim asNames() As String
'Прибыль филиалов.
Dim adValues() As Double
'Процентное отношение прибыли филиала к общей прибыли.
Dim aiPercents() As Double
'Номер последнего индекса, реально использовавшегося во время зачитывания данных.
Dim iMaxUsedIndex As Integer

Declare Sub SelectFileAndRefreshDiagram(ByVal strDiagramIndex As String)
Declare Sub AutoRefresh()
Declare Function RefreshDiagram(ByVal intDiagramIndex As Integer, ByVal strTextFileName As String) As Boolean
Declare Function LoadData(ByVal strFileName As String) As Boolean
Declare Function DrawDiagram(ByVal intDiagramIndex As Integer, ByVal strTextFileName As String) As Boolean
Declare Sub DrawSlice(ByVal iSliceNum As Integer, ByVal dSumPercent As Double, ByVal dNewPercent as Double, ByVal iR as Integer, ByVal iG as Integer, ByVal iB as Integer, ByVal DiagramShape As Shape, ByVal LegendShape As Shape)
Declare Sub DrawSliceFromLib(ByVal iSliceNum As Integer, ByVal dSumPercent As Double, ByVal dNewPercent as Double, ByVal iR as Integer, ByVal iG as Integer, ByVal iB as Integer, ByVal DiagramShape As Shape, ByVal LegendShape As Shape, ByVal libMaster As Master)

'========================================================================================================================
'========================================================================================================================

'Создание пользовательского меню. Автоматически вызывается при открытии документа из
'макроса уровня документа.
Sub CreateUserMenu()
    Dim custMenu As Menu
    Dim newMenuItem As MenuItem

    Set custMenu = thisDoc.CustomMenu
    custMenu.Caption = constrUserMenuName
    custMenu.RemoveAll()

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = constrFillFirstDiagram
    newMenuItem.OnCmdArgs = "1"
    newMenuItem.SetCmdProcessing("SelectFileAndRefreshDiagram")

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = constrFillSecondDiagram
    newMenuItem.OnCmdArgs = "2"
    newMenuItem.SetCmdProcessing("SelectFileAndRefreshDiagram")

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = constrRefreshBothDiagrams
    newMenuItem.SetCmdProcessing("AutoRefresh")
End Sub

'========================================================================================================================
'========================================================================================================================

'Автоматическое построение диаграммы по обновленным данным в текстовом файле.
'Если имя файла сохранено в Property объекта и такой файл существует, диаграмма будет пересчитана без
'запроса у пользователя нового имени файла данных.
Sub AutoRefresh()
On Error GoTo ErrHandler
    'Имя файла данных
    Dim strTextFileName As String
    'Ссылка на Custom Property объекта (в одном из них может храниться полное имя файла данных).
    Dim FileNameProp As CustomProp
    Dim NextShape As Shape
    Dim ActivePage As Page
    Dim i As Integer
    Dim j As Integer

    Set ActivePage = thisDoc.ActivePage()

    'Проверяем все шэйпы в документе. Шэйп, внутри которого обновляется диаграмма,
    'узнается по Name.
    For j=1 To ActivePage.ShapesNum()
        Set NextShape = ActivePage.Shape(j)
        Select Case NextShape.Name
        Case "Diagram1"
            intDiagramIndex = 1
        Case "Diagram2"
            intDiagramIndex = 2
        Case Else
            intDiagramIndex = 0
        End Select
        'Если найден шэйп диаграммы, проверяем, сохранено ли в нем Property с именем файла-источника данных.
        If intDiagramIndex <> 0 Then
            i=1
            Set FileNameProp = Nothing
            Do While i<=NextShape.CustomPropsNum() And FileNameProp = Nothing
                If NextShape.CustomProp(i).Label = "LastSourceFileName" Then
                    Set FileNameProp = NextShape.CustomProp(i)
                    strTextFileName = FileNameProp.Value
                    'Если Property существует, и существует файл, указанный в нем как источник данных,
                    'автоматически обновляем диаграмму.
                    If Dir(strTextFileName) <> "" Then
                         RefreshDiagram(intDiagramIndex, strTextFileName)
                    End If
                End If
                i = i + 1
            Loop
        End If
    Next

    Exit Sub
ErrHandler:
    MsgBox("In performing the macros, an error has occured.", cdbExclamation)
End Sub

'========================================================================================================================
'========================================================================================================================

'Для диаграммы указанного в параметре типа запрашиваем имя файла-источника данных и
'строим диаграмму на основании этих данных.
Sub SelectFileAndRefreshDiagram(ByVal strDiagramIndex As String)
On Error GoTo ErrHandler
    Dim strTextFileName As String

    Select Case strDiagramIndex
    Case "1"
        intDiagramIndex = 1
    Case "2"
        intDiagramIndex = 2
    Case Else
        intDiagramIndex = 0
    End Select

    'Предлагаем пользователю выбрать имя файла данных
    strTextFileName = GetOpenFileName("txt","Text Files")
    'Если фал выбран, строим диаграмму.
    If strTextFileName <> "" Then
         RefreshDiagram(intDiagramIndex, strTextFileName)
    End If
    Exit Sub
ErrHandler:
    MsgBox("In performing the macros, an error has occured.", cdbExclamation)
End Sub

'========================================================================================================================
'========================================================================================================================

'Обновляем диаграмму типа intDiagramIndex на основании данных в файле strTextFileName
Function RefreshDiagram(ByVal intDiagramIndex As Integer, ByVal strTextFileName As String) As Boolean
On Error GoTo ErrHandler
    RefreshDiagram = False

    Dim i As Integer

    i = conintMaxProcessingStrings - 1
    ReDim asNames(i) As String
    ReDim adValues(i) As Double
    ReDim aiPercents(i) As Double

    'Зачитываем данные из текстового файла и помещаем их в массивы. Если во время
    'выполнения функции LoadData не произошло ошибок...
    If intDiagramIndex <> 0 And LoadData(strTextFileName) Then
        '... то строим диаграмму. Если диаграмма построена успешно, сообщаем об этом пользователю.
        If DrawDiagram(intDiagramIndex, strTextFileName) Then
            RefreshDiagram = True
            MsgBox("Diagramma tipa " & CStr(intDiagramIndex) & " bila uspeshno obnovlena na osnovanii dannih iz faila " & strTextFileName)
        End If
    End If

    Exit Function
ErrHandler:
    MsgBox("In performing the macros, an error has occured.", cdbExclamation)
End Function

'========================================================================================================================
'========================================================================================================================

'Зачитывание данных из текстового файла strFileName и сохранение их в массивах.
Function LoadData(ByVal strFileName As String) As Boolean
On Error GoTo ErrHandle

    Dim intFileNumber As Integer        'Идентификатор обрабатываемого файла данных
    Dim strLineData As String        'Переменная, содержащая одну строку из текстового файла
    Dim intFieldsCounter As Integer    'Номер обрабатывающегося поля строки
    Dim intSeparatorPos As Integer    'Позиция разделителя полей строки
    Dim strFiels As String            'Содержимое одного поля строки
    Dim fNoError As Boolean            'Флаг, показывающий, что при обработке данных файла нет ошибок
    Dim strCharSeparator As String    'Разделитель полей строки
    Dim dSumOfValues As Double        'Общая прибыль во всех уже зачитанных филиалах
    Dim i As Integer

    strCharSeparator = constrCharSeparator

    fNoError = True

    'Открытие текстового файла для чтения данных
    intFileNumber = FreeFile()
    Open strFileName For Input As #intFileNumber

    iMaxUsedIndex = -1

    'Зачитываем по одной строке из до тех пор, пока не достигнем конца текстового файла или пока не возникнет ошибка
    Do While (Not EOF(intFileNumber)) And fNoError
        'Зачитать строку
        Line Input #intFileNumber, strLineData
        strLineData = Trim$(strLineData)
        'Если строка не пуста, обработаем ее.
        If strLineData <> "" Then
            'Увеличить на 1 значение наибольшего использующегося индекса в массивах.
            iMaxUsedIndex = iMaxUsedIndex + 1
            'Проверить, не слишком ли много строк в файле данных
            If  iMaxUsedIndex > conintMaxProcessingStrings-1 Then
                MsgBox("V faile soderzhits'a bolee " & conintMaxProcessingStrings & " strok. Eto slishkom mnogo dlja takoj diagrammi.")
                fNoError = False
            Else
                'Инициализация номера текущего поля текущей строки
                intFieldsCounter = 1
                Do
                    'Обрабатываем поля строки до тех пор, пока не достигнем конца строки.
                    'Данные из полей помещаем в массивы.
                    intSeparatorPos = InStr(strLineData, strCharSeparator)
                    If intSeparatorPos > 0 Then
                        strFiels = Trim(Left(strLineData, intSeparatorPos - 1))
                        strLineData = Right(strLineData, Len(strLineData) - intSeparatorPos)
                    Else
                        'Новый сепаратор не найден. Это последнее поле строки.
                        strFiels = Trim(strLineData)
                    End If
                    'Если номер поля равен одному из объявленных как содержащие данные для построения,
                    'заносим данные в массивы.
                    Select Case intFieldsCounter
                    Case aiNameFieldPos(intDiagramIndex-1)
                        asNames(iMaxUsedIndex) = strFiels
                    Case aiValueFieldPos(intDiagramIndex-1)
                        adValues(iMaxUsedIndex) = strFiels
                    Case Else
                    End Select
                    intFieldsCounter = intFieldsCounter + 1
                Loop While intSeparatorPos > 0
            End If
        End If
    Loop

    Close #intFileNumber

    'Проверить были ли в файле вообще какие-то данные.
    If iMaxUsedIndex = -1 Then
        fNoError = False
        MsgBox("V ukazannom faile ne obnaruzheni dannie.")
    End If


    If fNoError Then
        'Подсчитать общую прибыль по всем филиалам.
        dSumOfValues = 0
        For i = 0 To iMaxUsedIndex
            dSumOfValues = dSumOfValues + adValues(i)
        Next
        'Для каждого филиала подсчитать процент от общей прибыли.
        For i = 0 To iMaxUsedIndex
            aiPercents(i) = adValues(i) / dSumOfValues * 100
        Next
    End If

    LoadData = fNoError
    Exit Function

ErrHandle:
    MsgBox ("Proizoshla oshibka pri zachitivanii textovogo faila.", cdbExclamation)
    LoadData = False
    Exit Function
End Function

'========================================================================================================================
'========================================================================================================================

'Построение диаграммы в документе ConceptDraw
Function DrawDiagram(ByVal intDiagramIndex As Integer, ByVal strTextFileName As String) As Boolean
On Error GoTo ErrHandle
    Dim i As Integer
    Dim iR As Integer                'Цвет Red компоненты цвета Slice в RGB-представлении.
    Dim iG As Integer                'Цвет Green компоненты цвета Slice в RGB-представлении.
    Dim iB As Integer                'Цвет Blue компоненты цвета Slice в RGB-представлении.
    Dim dSumPercent As Double        'Суммарный процент прибыли в уже нарисованных филиалах по отношению ко все прибыли
    Dim dX As Double                'Координата X центра диаграммы
    Dim dY As Double                'Координата Y центра диаграммы
    Dim dR As Double                'Радиус диаграммы
    Dim dLegendX As Double            'Координаты левого верхнего угла легенды
    Dim dLegendY As Double
    Dim LegendFrame As Shape        'Ссылка на шэйп, представляющий рамку легенды
    Dim curPage As Page            'Ссылка на рабочую страницу
    Dim FileNameProp As CustomProp    'Ссылка на Custom Property объекта (в одном из них хранится полное имя файла данных).
    Dim workLib As Library            'Ссылка на открытую библиотеку, содержащую использующиеся объекты.
    Dim libMaster As Master            'Ссылка на Master, содержащий использующийся объект.
    Dim DiagramShape As Shape        'Ссылка на шэйп, представляющий диаграмму
    Dim LegendShape As Shape        'Ссылка на шэйп, представляющий легенду диаграммы
    Dim TitleShape As Shape            'Ссылка на шэйп, представляющий заголовок диаграммы

    Set curPage = thisDoc.Page(1)

    'В зависимости от индекса, определяем координаты диаграммы
    Select Case intDiagramIndex
    Case 1
        dX = 700
        dY = 800
        dR = 600
        dLegendX = 1400
        dLegendY = dY - dR
    Case 2
        dX = 700
        dY = 2300
        dR = 600
        dLegendX = 1400
        dLegendY = dY - dR
    End Select

    i=1
    Set DiagramShape = Nothing
    Set LegendShape = Nothing
    Set TitleShape = Nothing
    'Ищем в документе существующие шэйпы, в которых должны быть созданы диаграмма, ее легенда и ее заголовок.
    Do While i <= curPage.ShapesNum()
        if curPage.Shape(i).Name = "Diagram" & CStr(intDiagramIndex) Then
            Set DiagramShape = curPage.Shape(i)
        End If
        if curPage.Shape(i).Name = "Legend" & CStr(intDiagramIndex) Then
            Set LegendShape = curPage.Shape(i)
        End If
        if curPage.Shape(i).Name = "Title" & CStr(intDiagramIndex) Then
            Set TitleShape = curPage.Shape(i)
        End If
        i=i+1
    Loop
    'Если шэйп диаграммы не найден, он создается.
    If DiagramShape = Nothing Then
        Set DiagramShape = curPage.DrawGroup(dX - dR, dY - dR, dX + dR, dY + dR)
        DiagramShape.Name = "Diagram" & CStr(intDiagramIndex)
    Else
    'Если шэйп найден, выставляются его параметры и координаты.
        DiagramShape.RemoveAllShapes()
        DiagramShape.Height = 2*dR
        DiagramShape.Width = 2*dR
        DiagramShape.GPinX = dX
        DiagramShape.GPinY = dY
    End If
    'Аналогично для легенды и заголовка
    If LegendShape = Nothing Then
        Set LegendShape = curPage.DrawGroup(dLegendX, dLegendY, dLegendX + condblLegendWidth, dLegendY + (iMaxUsedIndex+1)*100-50)
        LegendShape.Name = "Legend" & CStr(intDiagramIndex)
    Else
        LegendShape.RemoveAllShapes()
        LegendShape.Height = (iMaxUsedIndex+1)*100-50
        LegendShape.Width = condblLegendWidth
        LegendShape.GPinX = dLegendX + LegendShape.Width/2
        LegendShape.GPinY = dLegendY + LegendShape.Height/2
    End If
    If TitleShape = Nothing Then
        Set TitleShape = curPage.DrawRect(100, dY-dR-150, 2000, dY-dR-50)
        TitleShape.Name = "Title" & CStr(intDiagramIndex)
    End If
    TitleShape.FillPattern = 0
    TitleShape.PenPattern = 0
    TitleShape.Text = "Dannie diagrammi importirovani iz kolonok " & aiNameFieldPos(intDiagramIndex - 1) & " i " & aiValueFieldPos(intDiagramIndex - 1) & " faila " & Chr(10) & strTextFileName
    TitleShape.SetParaHAlign(1, Len(TitleShape.Text), 0)
    TitleShape.SetCharSize(1, Len(TitleShape.Text), 11)
    TitleShape.SetCharStyle(1, Len(TitleShape.Text), 1)
    'Нарисовать рамку легенды
    Set LegendFrame = LegendShape.DrawRect(-10 , -10, LegendShape.Width+10, LegendShape.Height+10)
    LegendFrame.PenWeight = 6
    LegendFrame.PenColor.Index = 0
    LegendFrame.FillPattern = 0

    dSumPercent = 0
    Randomize
    'Если при построении диаграммы должны использоваться библиотечные объекты, открываю библиотеку,
    'проверяю, удалось ли ее открыть и есть ли в ней необходимый для работы объект.
    If bUseLibObjects Then
        'Открываю библиотеку ConceptDraw, содержащую использующиеся при построении схемы объекты
        Set workLib = thisApp.OpenLib("ChartingFigures.cdl")
        'Открылась ли библиотека?
        If Null = workLib Then
            DrawDiagram = False
            Msgbox("Ne udalos' otkrit' biblioteku ChartingFigures.cdl")
            Exit Function
        End If
        Set libMaster = workLib.MasterByName("Pie chart slice 2")
        'Есть ли нужный объект?
        If Null = libMaster Then
            DrawDiagram = False
            Msgbox("Ob'ekt ""Pie chart slice 2"" ne najden v biblioteke")
            Exit Function
        End If
    End If
    'Для каждого из филиалов добавляю в диаграмму объект, изображающий вклад филиала в общее дело.
    For i = 0 To iMaxUsedIndex
        'Определяю цвет сектора случайным образом.
        iR = Int(Rnd() * 255.999)
        iG = Int(Rnd() * 255.999)
        iB = Int(Rnd() * 255.999)
        'В зависимости от того, используется ли библиотечный объект или сектор рисуется полностью
        'с помощью ConceptDraw Basic, вызывается одна из двух альтернативных функций.
        If bUseLibObjects Then
            DrawSliceFromLib(i, dSumPercent, aiPercents(i), iR, iG, iB, DiagramShape, LegendShape, libMaster)
        Else
            DrawSlice(i, dSumPercent, aiPercents(i), iR, iG, iB, DiagramShape, LegendShape)
        End If
        'Увеличиваю значение суммарного процента уже нарисованных филиалов.
        dSumPercent = dSumPercent + aiPercents(i)
    Next

    i=1
    Set FileNameProp = Nothing
    'Перебираем CustomProperty объекта до тех пор, пока не будет найден тот, что содержит
    'имя файла данных. Его Label должен быть равен "LastSourceFileName"
    Do While i<=DiagramShape.CustomPropsNum() And FileNameProp = Nothing
        If DiagramShape.CustomProp(i).Label = "LastSourceFileName" Then
            Set FileNameProp = DiagramShape.CustomProp(i)
        End If
        i = i + 1
    Loop
    'Если такого CustomProperty не существует, он создается.
    If FileNameProp = Nothing Then
        Set FileNameProp = DiagramShape.AddCustomProp()
        FileNameProp.Label = "LastSourceFileName"
    End If
    'В CustomProperty записывается имя файла данных
    FileNameProp.Value = strTextFileName
    FileNameProp.Type = 0
    FileNameProp.Prompt = "Imja Fajla, ispol'zovavshegosja v kachestve poslednego istochnika dannih"

    DrawDiagram = True
    Exit Function
ErrHandle:
    MsgBox ("Proizoshla oshibka pri postroenii diagrammi.", cdbExclamation)
    DrawDiagram = False
    Exit Function
End Function

'========================================================================================================================
'========================================================================================================================

'Построение одного сектора, изображающего прибыль филиала. Построение без использование библиотечных объектов.
'iSliceNum - порядковый номер сектора
'dSumPercent - суммарный процент уже изображенных секторов
'dNewPercent - процент, который будет изображен этим сектором
'iR, iG, iB - составляющие RGB-представления цвет а сектора
'DiagramShape - ссылка на группу-шэйп диаграммы
'LegendShape - ссылка на группу-шэйп легенды
Sub DrawSlice(ByVal iSliceNum As Integer, ByVal dSumPercent As Double, ByVal dNewPercent as Double, ByVal iR as Integer, ByVal iG as Integer, ByVal iB as Integer, ByVal DiagramShape As Shape, ByVal LegendShape As Shape)

    'Координаты центра диаграммы в системе координат содержащей сектор группы
    Dim x1 As Double
    Dim y1 As Double
    'Радиус диаграммы
    Dim r As Double

    'Координаты точек, используемых при построении сектора.
    'Координаты начальной точки дуги сектора.
    Dim x2 As Double
    Dim y2 As Double
    'Координаты конечной точки дуги сектора.
    Dim x3 As Double
    Dim y3 As Double
    'Координаты середины дуги сектора.
    Dim x4 As Double
    Dim y4 As Double
    'Угол, на который начало сектора отстоит от начальной оси.
    Dim dCurrAngle as Double
    'Центральный угол сектора.
    Dim dSliceAngle as Double
    'Ссылка на объект-шэйп, представляющий новый Slice.
    Dim newSlice As Shape
    'Координаты центра текста объекта
    Dim TextCenter As DPoint
    'Ссылка на шэйп, представляющий цветной прямоугольник в легенде, соответствующий этому сектору
    Dim LegendColorRect As Shape
    'Ссылка на шэйп, представляющий текст в легенде, соответствующий этому сектору
    Dim TextBoxShape As Shape

    Set TextCenter = New DPoint

    x1 = DiagramShape.Width/2
    y1 = DiagramShape.Height/2
    r = DiagramShape.Width/2

    'Вычисление координат точек, по которым строится Slice.
    'Координаты относительно системы координат родительской группы.
    'Вычисляются по радиусу окружности и углу поворота относительно начальной оси.
    dCurrAngle = (2 * 3.14159265 * dSumPercent )/100
    dSliceAngle = (2 * 3.14159265 * dNewPercent )/100
    x2 = r * cos(dCurrAngle) + x1
    y2 = r * sin(dCurrAngle) + y1
    x3 = r * cos(dCurrAngle + dSliceAngle) + x1
    y3 = r * sin(dCurrAngle + dSliceAngle) + y1
    x4 = r * cos(dCurrAngle + dSliceAngle/2) + x1
    y4 = r * sin(dCurrAngle + dSliceAngle/2) + y1
    TextCenter.X = 0.8 * r * cos(dCurrAngle + dSliceAngle/2) + x1
    TextCenter.Y = 0.8 * r * sin(dCurrAngle + dSliceAngle/2) + y1


    Set active_Page = thisDoc.ActivePage()
    'Построение сектора по полученным координатам
    Set newSlice = DiagramShape.BeginShape()
    newSlice.FillColor.SetRGB(iR, iG, iB)
    newSlice.FillPattern = 1
    newSlice.Text = CInt(dNewPercent) & "%"
    'Цвет текста сегмента устанавливается таким, чтобы он всегда был виден на фоне сегмента
    newSlice.SetCharColor(1, Len(newSlice.Text), 255 - iR, 255 - iG, 255 - iB)
    DiagramShape.MoveTo(x1,y1)
    DiagramShape.LineTo(x2,y2)
    DiagramShape.ArcTo(x3, y3, x4, y4)
    DiagramShape.LineTo(x1, y1)
    DiagramShape.EndShape()

    'Преобразование координат центра текста сектора из системы  координат родительской группы
    'в локальную систему координат.
    newSlice.GPtoLP(TextCenter)
    'Определение свойств текста сектора
    newSlice.TextGPinX = TextCenter.X
    newSlice.TextGPinY = TextCenter.Y
    newSlice.TextWidth = 100
    newSlice.TextHeight = 50
    newSlice.SetCharSize(1, Len(newSlice.Text), 12)
    newSlice.SetCharStyle(1, Len(newSlice.Text), 1)

    'Создание в Легенде определения данного сектора

    'Создаем квадрат, цвет которого совпадает с цветом сектора
    Set LegendColorRect = LegendShape.DrawRect(0, iSliceNum*100, 50, iSliceNum*100+50)
    LegendColorRect.FillColor.SetRGB(iR, iG, iB)
    LegendColorRect.FillPattern = 1
    'Создаем TextBox с описанием филиала и его прибыли.
    Set TextBoxShape = LegendShape.DrawRect(100, iSliceNum*100, condblLegendWidth, iSliceNum*100+50)
    TextBoxShape.FillPattern = 0
    TextBoxShape.PenPattern = 0
    TextBoxShape.Text = asNames(iSliceNum) & ", " & adValues(iSliceNum) & "$"
    TextBoxShape.SetParaHAlign(1, Len(TextBoxShape.Text), 0)
    TextBoxShape.SetCharSize(1, Len(TextBoxShape.Text), 10)
    TextBoxShape.SetCharStyle(1, Len(TextBoxShape.Text), 0)

    Set TextCenter = Nothing
End Sub

'========================================================================================================================
'========================================================================================================================

'Построение одного сектора, изображающего прибыль филиала.
'iSliceNum - порядковый номер сектора
'dSumPercent - суммарный процент уже изображенных секторов
'dNewPercent - процент, который будет изображен этим сектором
'iR, iG, iB - составляющие RGB-представления цвет а сектора
'DiagramShape - ссылка на группу-шэйп диаграммы
'LegendShape - ссылка на группу-шэйп легенды
'libMaster - ссылка на Master использующегося библиотечного объекта
Sub DrawSliceFromLib(ByVal iSliceNum As Integer, ByVal dSumPercent As Double, ByVal dNewPercent as Double, ByVal iR as Integer, ByVal iG as Integer, ByVal iB as Integer, ByVal DiagramShape As Shape, ByVal LegendShape As Shape, ByVal libMaster As Master)
    'Координаты центра диаграммы в системе координат содержащей сектор группы
    Dim x1 As Double
    Dim y1 As Double
    'Радиус диаграммы
    Dim r As Double

    'Координаты конечной точки дуги сектора.
    Dim x3 As Double
    Dim y3 As Double
    'Угол, на который конец сектора отстоит от начальной оси.
    Dim dCurrAngle as Double
    'Ссылка на объект-шэйп, представляющий новый сектор.
    Dim newSlice As Shape

    'Ссылка на шэйп, представляющий цветной прямоугольник в легенде, соответствующий этому сектору
    Dim LegendColorRect As Shape
    'Ссылка на шэйп, представляющий текст в легенде, соответствующий этому сектору
    Dim TextBoxShape As Shape

    x1 = DiagramShape.Width/2
    y1 = DiagramShape.Height/2
    r = DiagramShape.Width/2

    'Вычисление координат точек, по которым строится Slice.
    'Координаты относительно системы координат родительской группы.
    'Вычисляются по радиусу окружности и углу поворота относительно начальной оси.
    dCurrAngle = (2 * 3.14159265 * (dSumPercent + dNewPercent))/100
    x3 = r * cos(dCurrAngle) + x1
    y3 = r * sin(dCurrAngle) + y1

    Set active_Page = thisDoc.ActivePage()
    'Построение сектора по полученным координатам
    Set newSlice = DiagramShape.DrawStamp(libMaster.Shape, x1, y1, x3, y3)
    newSlice.FillColor.SetRGB(iR, iG, iB)
    newSlice.Text = CInt(dNewPercent*10)/10 & "%"
    'Цвет текста сегмента устанавливается таким, чтобы он всегда был виден на фоне сегмента
    newSlice.SetCharColor(1, Len(newSlice.Text), 255 - iR, 255 - iG, 255 - iB)


    Set LegendColorRect = LegendShape.DrawRect(0, iSliceNum*100, 50, iSliceNum*100+50)
    'Создаем квадрат, цвет которого совпадает с цветом сектора
    LegendColorRect.FillColor.SetRGB(iR, iG, iB)
    LegendColorRect.FillPattern = 1
    'Создаем TextBox с описанием филиала и его прибыли.
    Set TextBoxShape = LegendShape.DrawRect(100, iSliceNum*100, condblLegendWidth, iSliceNum*100+50)
    TextBoxShape.FillPattern = 0
    TextBoxShape.PenPattern = 0
    TextBoxShape.Text = asNames(iSliceNum) & ", " & adValues(iSliceNum) & "$"
    TextBoxShape.SetParaHAlign(1, Len(TextBoxShape.Text), 0)
    TextBoxShape.SetCharSize(1, Len(TextBoxShape.Text), 10)
    TextBoxShape.SetCharStyle(1, Len(TextBoxShape.Text), 0)

    Set TextCenter = Nothing
End Sub