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

Text File | 2004-02-13 | 25.5 KB | 544 lines

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

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

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

'Индекс диаграммы, которая будет создана при данном вызове функции построения.
Dim intDiagramIndex As Integer

'Массивы, содержащие данные о работе филиалов.
'Имена филиалов.
Dim asNames() As String
'Прибыль филиалов.
Dim adValues() 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 Function CalcScaleStep(ByRef dblMaxProd As Double) As Double
'Declare Sub RefreshSelected()



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

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

    Set custMenu = thisDoc.CustomMenu
    custMenu.Caption = "Fill Di&agrams"
    custMenu.RemoveAll()

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = "Fill 2D Diagram 1 Tipa"
    newMenuItem.OnCmdArgs = "1"
    newMenuItem.SetCmdProcessing("SelectFileAndRefreshDiagram")

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = "Fill 3D Diagram 1 Tipa"
    newMenuItem.OnCmdArgs = "2"
    newMenuItem.SetCmdProcessing("SelectFileAndRefreshDiagram")

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = "Fill 2D Diagram 2 Tipa"
    newMenuItem.OnCmdArgs = "3"
    newMenuItem.SetCmdProcessing("SelectFileAndRefreshDiagram")

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = "Fill 3D Diagram 2 Tipa"
    newMenuItem.OnCmdArgs = "4"
    newMenuItem.SetCmdProcessing("SelectFileAndRefreshDiagram")

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = "&Refresh All Diagrams"
    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 "Diagram3"
            intDiagramIndex = 3
        Case "Diagram4"
            intDiagramIndex = 4
        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 "3"
        intDiagramIndex = 3
    Case "4"
        intDiagramIndex = 4
    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

    'Зачитываем данные из текстового файла и помещаем их в массивы. Если во время
    'выполнения функции 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

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

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

    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 компоненты цвета столбца в RGB-представлении.
    Dim iG As Integer                'Цвет Green компоненты цвета столбца в RGB-представлении.
    Dim iB As Integer                'Цвет Blue компоненты цвета столбца в RGB-представлении.
    Dim dblX0 As Double                  'Координаты левого нижнего угла диаграммы
    Dim dblY0 As Double
    Dim dblUnitY As Double               'the height of the elements in "Graph  scale 4"
    Dim strLibObjTextBar As String       'the name of the library object representing the bars of the diagram
    Dim dblStepScale As Double           'the scale of the diagram
    Dim intScaleStepCount As Integer     'the number of elements in "Graph  scale 4"
    Dim dblDiagWidth As Double        'Высота диаграммы
    Dim dblDiagHeight As Double        'Ширина диаграммы
    Dim curPage As Page            'Ссылка на рабочую страницу
    Dim FileNameProp As CustomProp    'Ссылка на Custom Property объекта (в одном из них хранится полное имя файла данных).
    Dim dblMaxProd As Double        'Наибольшее значение прибыли для всех филиалов
    Dim dblBarWidth As Double        'Ширина столбца диаграммы
    Dim dblBarHeight As Double        'Высота текущего столбца диаграммы
    Dim workLib As Library            'Ссылка на открытую библиотеку, содержащую использующиеся объекты.
    Dim libBarMaster As Master        'Ссылка на Master, содержащий использующийся объект.
    Dim libScaleMaster As Master        'Ссылка на Master, содержащий использующийся объект для отображения Scale.
    Dim ScaleShape As Shape            'Ссылка на объект, изображающий Scale
    Dim BarShape As Shape            'Ссылка на объект, изображающий столбец диаграммы
    Dim BarTextShape As Shape        'Ссылка на шэйп, представляющий подпись к столбцу диаграммы
    Dim DiagramShape As Shape        'Ссылка на шэйп, представляющий диаграмму
    Dim TitleShape As Shape            'Ссылка на шэйп, представляющий заголовок диаграммы
    Dim ValueText As Shape            'Ссылка на шэйп, содержащий значение прибыли филиала, соответствующего столбцу диаграммы
    Dim intCharColor As Integer        'Цвет текста в индексном представлении цвета
    Dim dblTitleYShift As Double        'Смещение заголовка диаграммы по отношению к диаграмме по вертикали


    Set curPage = thisDoc.Page(1)

    'Определяем наибольшее значение прибыли во всех филиалах
    dblMaxProd = 0
    For i = 0 To iMaxUsedIndex
        If dblMaxProd < adValues(i) Then
            dblMaxProd = adValues(i)
        End If
    Next

    'Вычисляем параметры диаграммы - масштаб, количество наносимых делений, количество единиц,
    'которые изображает каждое деление, ширину столбца
    dblStepScale = CalcScaleStep(dblMaxProd)
    intFilialCount = iMaxUsedIndex + 1
    If 100 < 2000 / intFilialCount Then
        dblBarWidth = 100
    Else
        dblBarWidth = 2000 / intFilialCount
    End If
    intScaleStepCount = dblMaxProd \ dblStepScale
    If intScaleStepCount < 10 Then
        intScaleStepCount = intScaleStepCount + 1
    End If
    dblUnitY = 1000 \ intScaleStepCount
    'Определяем положение и размер диаграммы и подписи к ней.
    Select Case intDiagramIndex
    Case 1
        dblDiagWidth = intFilialCount * dblBarWidth
        dblDiagHeight = dblUnitY * intScaleStepCount
        dX0 = 200
        dY0 = 250 + dblDiagHeight
        dblTitleYShift = 150
        strLibObjTextBar = "Vertical text bar"
    Case 2
        dblDiagWidth = intFilialCount * dblBarWidth
        dblDiagHeight = dblUnitY * intScaleStepCount
        dX0 = 200
        dY0 = 2900
        dblTitleYShift = 200
        strLibObjTextBar = "Vertical   3-D bar"
    Case 3
        dblDiagWidth = dblUnitY * intScaleStepCount
        dblDiagHeight = intFilialCount * dblBarWidth
        dX0 = 2000
        dY0 = 250 + dblDiagHeight
        dblTitleYShift = 150
        strLibObjTextBar = "Vertical text bar"
    Case 4
        dblDiagWidth = dblUnitY * intScaleStepCount
        dblDiagHeight = intFilialCount * dblBarWidth
        dX0 = 2000
        dY0 = 2800
        dblTitleYShift = 200
        strLibObjTextBar = "Vertical   3-D bar"
    End Select
    i=1
    Set DiagramShape = 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 = "Title" & CStr(intDiagramIndex) Then
            Set TitleShape = curPage.Shape(i)
        End If
        i=i+1
    Loop
    'Если шэйп диаграммы не найден, он создается.
    If DiagramShape = Nothing Then
        Set DiagramShape = curPage.DrawGroup(dX0, dY0 - dblDiagHeight, dX0 + dblDiagWidth, dY0)
        DiagramShape.Name = "Diagram" & CStr(intDiagramIndex)
    Else
    'Если шэйп найден, он очищается от Child-объектов, выставляются его параметры и координаты.
        DiagramShape.RemoveAllShapes()
        DiagramShape.Height = dblDiagHeight
        DiagramShape.Width = dblDiagWidth
        DiagramShape.GPinX = dX0 + dblDiagWidth/2
        DiagramShape.GPinY = dY0 - dblDiagHeight/2
    End If
    'Аналогично для заголовка
    If TitleShape = Nothing Then
        Set TitleShape = curPage.DrawRect(dX0, dY0 - dblDiagHeight-dblTitleYShift-50, dX0 + dblDiagWidth, dY0 - dblDiagHeight-dblTitleYShift+50)
        TitleShape.Name = "Title" & CStr(intDiagramIndex)
    Else
        TitleShape.Height = 100
        TitleShape.Width = 1800
        TitleShape.GPinX = dX0 + TitleShape.Width/2 - 100
        TitleShape.GPinY = dY0 - dblDiagHeight - dblTitleYShift
    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)

    'Открываю библиотеку 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 libBarMaster = workLib.MasterByName(strLibObjTextBar)
    If Null = libBarMaster Then
        DrawDiagram = False
        Msgbox("Ob'ekt """ & strLibObjTextBar & """ ne najden v biblioteke")
        Exit Function
    End If
    Set libScaleMaster = workLib.MasterByName("Graph  scale 4")
    If Null = libScaleMaster Then
        DrawDiagram = False
        Msgbox("Ob'ekt ""Graph  scale 4"" ne najden v biblioteke")
        Exit Function
    End If
    'В диаграмму помещаются объекты, изображающие шкалу.
    For i=1 To intScaleStepCount
        If intDiagramIndex = 1 Or intDiagramIndex = 2 Then
            Set ScaleShape = DiagramShape.DropStamp(libScaleMaster.Shape, - 25, dblDiagHeight - dblUnitY *(i - 0.5))
        Else
            Set ScaleShape = DiagramShape.DropStamp(libScaleMaster.Shape, dblUnitY *(i - 0.5), dblDiagHeight + 25)
            ScaleShape.FlipY = True
            ScaleShape.Angle = -1.570796
            ScaleShape.TextAngle = 3.141593
        End If
        ScaleShape.Width = 50
        ScaleShape.Height = dblUnitY
        ScaleShape.Text = CStr(dblStepScale * i)
    Next
    Randomize
    'Помещаю в диаграмму столбцы, изображающие прибыль, полученную филиалом.
    For i = 0 To iMaxUsedIndex
        'Определяю цвет столбца случайным образом.
        iR = Int(Rnd() * 255.999)
        iG = Int(Rnd() * 255.999)
        iB = Int(Rnd() * 255.999)
        dblBarHeight = adValues(i) * dblUnitY / dblStepScale
        Select Case intDiagramIndex
        Case 1, 2
            'Помещаю столбец
            Set BarShape = DiagramShape.DropStamp(libBarMaster.Shape, dblBarWidth*(i+0.5), dblDiagHeight - dblBarHeight / 2)
            'Помещаю подпись к столбцу с текстом, содержащим значение размера прибыли
            Set ValueText = DiagramShape.DrawRect(dblBarWidth*i, dblDiagHeight - dblBarHeight - 50, dblBarWidth*(i+1), dblDiagHeight - dblBarHeight)
        Case 3, 4
            Set BarShape = DiagramShape.DropStamp(libBarMaster.Shape, dblBarHeight / 2, dblDiagHeight - dblBarWidth*(i + 0.5))
            Set ValueText = DiagramShape.DrawRect(dblBarHeight, dblDiagHeight - dblBarWidth*(i + 0.5) - 25, dblBarHeight + 150, dblDiagHeight - dblBarWidth*(i + 0.5) + 25)
            BarShape.FlipX = True
            BarShape.Angle = 1.570796
        End Select
        'Уточняю свойства объектов для наиболее удобного отображения.
        ValueText.Text = CStr(adValues(i))
        ValueText.PenPattern = 0
        ValueText.FillPattern = 0
        ValueText.SetCharSize(1, Len(ValueText.Text), 9)
        ValueText.SetCharColor(1, Len(ValueText.Text), 0, 0, 0)
        BarShape.Width = dblBarWidth
        BarShape.Height = dblBarHeight
        'Нахожу шэйп, в котором будет выведет текст внутри столбца. Текст содержит описание филиала.
        If BarShape.ShapesNum()>0 Then
            Set BarTextShape = BarShape.Shape(BarShape.ShapesNum())
        Else
            Set BarTextShape = BarShape
        End If
        BarTextShape.Text = asNames(i)
        'Устанавливаю цвет текста в столбце. Текст должен всегда виден на фоне столбца.
        BarTextShape.FillColor.SetRGB(iR,iG,iB)
        If iR<90 Or iG<90 Or iB<90 Then
            intCharColor = 255
        Else
            intCharColor = 0
        End If
        BarTextShape.SetCharColor(1, Len(BarTextShape.Text), intCharColor, intCharColor, intCharColor)
    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
    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

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

'Adjusting the suitable scale for the diagram
Function CalcScaleStep(ByRef dblMaxProd As Double) As Double
    CalcScaleStep = 1
    If dblMaxProd > 0 Then 'Checking the correctness of the parameter
        CalcScaleStep = 10 ^ Int(Log(dblMaxProd) / Log(10))
        If CalcScaleStep = dblMaxProd Then
            CalcScaleStep = CalcScaleStep / 10
        End If
    End If
End Function