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

Text File | 2004-02-13 | 20.6 KB | 383 lines

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

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

'Максимальное количество строк данных, которое ожидается в файле данных. Без учета
'первой (заголовочной строки).
Const conintMaxDataStrings As Integer = 31

'Масштаб диаграммы по оси OX. Количество юнитов в единице шкалы.
Const condblXScale As Double = 50
'Масштаб диаграммы по оси OY. Количество юнитов в единице шкалы.
Const condblYScale As Double = 50
'Минимальное значение по оси OX, которое будет использоваться в диаграмме.
Const condblMinX As Double = 1
'Максимальное значение по оси OX, которое будет использоваться в диаграмме.
Const condblMaxX As Double = 31
'Минимальное значение по оси OY, которое будет использоваться в диаграмме.
Const condblMinY As Double = 9
'Максимальное значение по оси OY, которое будет использоваться в диаграмме.
Const condblMaxY As Double = 50

Declare Sub SelectFileAndRefreshDiagram()
Declare Sub AutoRefresh()
Declare Function RefreshDiagram(ByVal strTextFileName As String) As Boolean
Declare Function LoadData(ByVal strFileName As String) As Boolean
Declare Function DrawDiagram(ByVal strTextFileName As String) As Boolean
Declare Function DrawTextBox(ByVal GroupShape As Shape, ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double, ByVal strText As String, ByVal lTextSize As Long, ByVal lTextStyle As Long) As Shape

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

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

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

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = "&Select File And Refresh Diagram"
    newMenuItem.SetCmdProcessing("SelectFileAndRefreshDiagram")

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = "&Refresh Diagram"
    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)
        If NextShape.Name = "Diagram" Then
        'Если найден шэйп диаграммы, проверяем, сохранено ли в нем Property с именем файла-источника данных.
            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(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()
On Error GoTo ErrHandler
    Dim strTextFileName As String

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

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

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

    'Зачитываем данные из текстового файла и помещаем их в массивы. Если во время
    'выполнения функции LoadData не произошло ошибок...
    If LoadData(strTextFileName) Then
        '... то строим диаграмму. Если диаграмма построена успешно, сообщаем об этом пользователю.
        If DrawDiagram(strTextFileName) Then
            RefreshDiagram = True
            MsgBox("Diagramma 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 i As Integer

    strCharSeparator = constrCharSeparator

    fNoError = True

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


    iMaxUsedIndex = -2
    iNamesUBound = -1

    'Зачитываем по одной строке из до тех пор, пока не достигнем конца текстового файла или пока не возникнет ошибка
    Do While (Not EOF(intFileNumber)) And fNoError
        'Зачитать строку
        Line Input #intFileNumber, strLineData
        strLineData = Trim$(strLineData)
        'Если строка не пуста, обработаем ее.
        If strLineData <> "" Then
            'Увеличить на 1 значение наибольшего использующегося индекса второй размерности в массиве.
            iMaxUsedIndex = iMaxUsedIndex + 1
            'Проверить, не слишком ли много строк в файле данных
            If  iMaxUsedIndex > conintMaxDataStrings-1 Then
                MsgBox("V faile soderzhits'a bolee " & conintMaxDataStrings  & " stroki dannih, ne schitaja zagolovochnoj. Eto slishkom mnogo dlja odnomesjachnoj 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
                    If iMaxUsedIndex = -1 Then
                        'Если анализируется первая (заголовочная) строка, увеличиваем размер массива с названиями станций
                        iNamesUBound = intFieldsCounter - 1
                        ReDim Preserve asNames(iNamesUBound) As String
                        'И помещаем в массив новое значение.
                        asNames(iNamesUBound) = strFiels
                    Else
                        'Если анализируем строку данных, помещаем в массив значений измерений новое число.
                        adValues(intFieldsCounter - 1, iMaxUsedIndex) = CDbl(strFiels)
                    End If
                    intFieldsCounter = intFieldsCounter + 1
                Loop While intSeparatorPos > 0
                'Если завершен анализ заголовочной строки, изменяем размер двумерного массива значений так, чтобы в нем могли быть размещены данные со всех станций.
                If iMaxUsedIndex = -1 Then
                    i = conintMaxDataStrings - 1
                    ReDim adValues(iNamesUBound, i) As Double
                End If
            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 strTextFileName As String) As Boolean
On Error GoTo ErrHandle
    Dim i As Long
    Dim j As Long
    Dim dblDiagHeight As Double        'Высота группы, содержащей диаграмму
    Dim curPage As Page            'Ссылка на рабочую страницу
    Dim FileNameProp As CustomProp    'Ссылка на Custom Property объекта (в одном из них хранится полное имя файла данных).
    Dim DiagramShape As Shape        'Ссылка на шэйп, представляющий диаграмму
    Dim LineShape As Shape            'Ссылка на шэйп, представляющий линию графика
    Dim LegendShape As Shape        'Ссылка на шэйп, представляющий легенду диаграммы
    Dim TextBox As Shape            'Ссылка на шэйп, представляющий текстовую подпись
    Dim strLostShapesName As String    'Строка, содержащее имя удаленного шэйпа, необходимого для корректной работы макроса
    Dim intLineColor As Integer        'Цвет линии диаграммы в индексном представлении


    Set curPage = thisDoc.Page(1)

    i=1
    Set DiagramShape = Nothing
    Set LegendShape = Nothing
    'Ищем в документе необходимые шэйпы, в которых должны быть созданы диаграмма и ее легенда.
    Do While i <= curPage.ShapesNum()
        if curPage.Shape(i).Name = "Diagram" Then
            Set DiagramShape = curPage.Shape(i)
        End If
        if curPage.Shape(i).Name = "Legend" Then
            Set LegendShape = curPage.Shape(i)
        End If
        i=i+1
    Loop
    strLostShapesName = ""
    If DiagramShape = Nothing Then
        strLostShapesName = "Diagram"
    End If
    If LegendShape = Nothing Then
        strLostShapesName = "Legend"
    End If
    'Если шэйп диаграммы не найден, выдается сообщение об ошибке и выполнение макроса прекращается.
    If strLostShapesName <> "" Then
        MsgBox("Voznikla oshibka. Neobhodimij dlja postroenija diagrammi ob'ekt s name """ & strLostShapesName & """ v dokumente ne najden.")
        DrawDiagram = False
        Exit Function
    End If

    'Группа, в которой изображается легенда диаграммы, очищается от всех child-шэйпов.
    LegendShape.RemoveAllShapes()
    DrawTextBox(LegendShape, 0, 0, LegendShape.Width, 100, "Dannie izmereniy v 1:00 PM", 12, 7)


    'Группа, в которой изображается диаграмма, очищается от child-шэйпов. Остаются только оси и их подписи.
    'Поскольку после удаления одного шэйпа индексы остальных автоматически пересчитываются,
    'чтобы заполнить выпавший индекс, перебор элементов начинается с наибольшего индекса.
    For i=DiagramShape.ShapesNum() To 1 Step -1
        If DiagramShape.Shape(i).Name <> "DescX" And DiagramShape.Shape(i).Name <> "DescY" And DiagramShape.Shape(i).Name <> "OX" And DiagramShape.Shape(i).Name <> "OY" Then
            DiagramShape.RemoveShape(i)
        End If
    Next

    'Наносим шкалу на ось OY
    dblDiagHeight = DiagramShape.Height
    For i=condblMinY+1 To condblMaxY
        'Штрих оси OY
        DiagramShape.DrawLine(-10, dblDiagHeight - (i - condblMinY)*condblYScale, 10, dblDiagHeight - (i - condblMinY)*condblYScale)
        'Подпись возле штриха
        DrawTextBox(DiagramShape, -70, dblDiagHeight - (i - condblMinY)*condblYScale - 25, -20, dblDiagHeight - (i - condblMinY)*condblYScale + 25, CStr(i), 10, 0)
    Next
    'Наносим шкалу на ось OX
    For i=1 To iMaxUsedIndex
        'Штрих оси OX
        DiagramShape.DrawLine((adValues(0,i)-condblMinX)*condblXScale, dblDiagHeight + 10, (adValues(0,i)-condblMinX)*condblXScale, dblDiagHeight - 10)
        'Подпись под штрихом
        DrawTextBox(DiagramShape, (adValues(0,i)-condblMinX)*condblXScale-25, dblDiagHeight + 20, (adValues(0,i)-condblMinX)*condblXScale+25, dblDiagHeight+70, CStr(adValues(0,i)), 10, 0)
    Next

    'Для каждой станции рисуем график температур за месяц
    For i = 1 To iNamesUBound
        intLineColor = i
        Set LineShape = DiagramShape.BeginShape()
        LineShape.PenColor.Index = intLineColor
        LineShape.PenWeight = 6
        LineShape.MoveTo((adValues(0,0)-condblMinX)*condblXScale, dblDiagHeight - (adValues(i,0)-condblMinY)*condblYScale)
        For j=1 To iMaxUsedIndex
            DiagramShape.LineTo((adValues(0,j)-condblMinX)*condblXScale, dblDiagHeight - (adValues(i,j)-condblMinY)*condblYScale)
        Next j
        DiagramShape.EndShape()
        'Помещаем в Легенду описание линии графика
        Set LineShape = LegendShape.DrawLine(0, 50 + i*100, LegendShape.Width/4, 50 + i*100)
        LineShape.PenColor.Index = intLineColor
        LineShape.PenWeight = 6
        DrawTextBox(LegendShape, LegendShape.Width/4, 25 + i*100, LegendShape.Width, 75 + i*100, asNames(i), 10, 1)
    Next i

    i=1
    Set FileNameProp = Nothing
    'Проверяем, есть ли в диаграмме CustomProperty с именем файла-источника данных.
    'Если есть, помещаем в него имя последнего использовавшегося файла.
    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

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

'Создание шэйпа TextBox с некоторым текстом.
'GroupShape - ссылка на шэйп-группу, внутри которой должна быть помещена надпись
'x1, y1 - координаты верхнего левого угла прямоугольника с текстом в системе координат родительского шэйпа
'x2, y2 - координаты правого нижнего угла прямоугольника с текстом в системе координат родительского шэйпа
'strText - текст надписи
'lTextSize - размер шрифта
'lTextStyle - стиль шрифта
Function DrawTextBox(ByVal GroupShape As Shape, ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double, ByVal strText As String, ByVal lTextSize As Long, ByVal lTextStyle As Long) As Shape
    Set DrawTextBox= GroupShape.DrawRect(x1, y1, x2, y2)
    DrawTextBox.FillPattern = 0
    DrawTextBox.PenPattern = 0
    DrawTextBox.Text = strText
    DrawTextBox.SetCharSize(1, Len(strText), lTextSize)
    DrawTextBox.SetCharStyle(1, Len(strText), lTextStyle)
    DrawTextBox.SetCharColor(1, Len(strText), 0, 0, 0)
End Function