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

Text File | 2004-02-13 | 21.9 KB | 444 lines

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

'Массив, в котором записывается траффик на каждый день месяца
Dim adValues(30) As Double

'Масштаб диаграммы по оси OX. Количество юнитов в единице шкалы.
Const condblXScale As Double = 50

'Максимальное значение по оси OX, которое будет использоваться в диаграмме. Количество дней в месяце.
Dim intMaxX As Integer
'Максимальный траффик в течение одного дня за месяц.
Dim dblMaxDayTraffic As Double
'Суммарный траффик за месяц.
Dim dblMonthTraffic As Double

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, ByVal intHAlign As Byte) As Shape
Declare Function CalcScaleStep(ByRef dblMax As Double) As Double


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

'Создание пользовательского меню. Автоматически вызывается при открытии документа из
'макроса уровня документа.
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 = "&Select File And Refresh Diagrams"
    newMenuItem.SetCmdProcessing("SelectFileAndRefreshDiagram")

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = "&Refresh 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)
        If NextShape.Name = "DiagramDay" 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 intSeparatorPos As Integer    'Позиция разделителя данных строки
    Dim fNoError As Boolean            'Флаг, показывающий, что при обработке данных файла нет ошибок
    Dim intDate As Integer            'Дата, к которой относится анализируемое значение траффика
    Dim i As Integer

    fNoError = True

    For i=0 To 30
        adValues(i)=0
    Next
    intMaxX = 0

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

    'Зачитываем по одной строке из до тех пор, пока не достигнем конца текстового файла или пока не возникнет ошибка
    Do While (Not EOF(intFileNumber)) And fNoError
        'Зачитать строку
        Line Input #intFileNumber, strLineData
        strLineData = Trim$(strLineData)
        'Если строка не пуста, обработаем ее.
        If strLineData <> "" Then
            'Найти положение символа "/", ограничивающего дату в строке
            intSeparatorPos = InStr(strLineData, "/")
            If intSeparatorPos > 0 Then
                intDate = CInt(Left(strLineData, intSeparatorPos-1))
                If intDate > intMaxX Then
                    intMaxX = intDate
                End If
                'Найти положение пробела, ограничивающего показатель траффика в строке
                intSeparatorPos = InStr(strLineData, " ")
                If intSeparatorPos > 0 Then
                    'Добавить показание траффика в соответствующий дате элемент массива
                    adValues(intDate-1)=adValues(intDate-1)+CDbl(Right(strLineData, Len(strLineData) - intSeparatorPos))
                End If
            End If
        End If
    Loop
    dblMaxDayTraffic = 0
    dblMonthTraffic = 0
    For i=0 To intMaxX -1
        'Перевести значение траффика из байт в мегабайты
        adValues(i)=adValues(i)/1024^2
        'Найти найбольшее значение траффика в день в этом месяце.
        If dblMaxDayTraffic < adValues(i) Then
            dblMaxDayTraffic = adValues(i)
        End If
        'Найти суммарное значение траффика за месяц
        dblMonthTraffic = dblMonthTraffic + adValues(i)
    Next

    Close #intFileNumber

    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 dblDiagHeight As Double        'Высота группы, содержащей диаграмму
    Dim curPage As Page            'Ссылка на рабочую страницу
    Dim FileNameProp As CustomProp    'Ссылка на Custom Property объекта (в одном из них хранится полное имя файла данных).
    Dim DiagramDayShape As Shape        'Ссылка на шэйп диаграммы, изображающей траффик за каждый день месяца
    Dim DiagramSumShape As Shape        'Ссылка на шэйп диаграммы, изображающей суммарный траффик за месяц
    Dim LineShape As Shape            'Ссылка на шэйп, представляющий линию графика
    Dim TextBox As Shape            'Ссылка на шэйп, представляющий текстовую подпись
    Dim strLostShapesName As String    'Строка, содержащее имя удаленного шэйпа, необходимого для корректной работы макроса
    Dim dblSumTraffic As Double        'Суммарный траффик с начала месяца
    Dim dblMaxY As Double            'Количество делений шкалы, которое будет изображено по оси OY
    Dim intStep As Integer            'Количество единиц, которому соответствует одно деление шкалы
    Dim dblStepScale As Double        'Количество мегабайт, которое изображает одна единица шкалы
    Dim dblScale As Double            'Масштаб диаграммы по оси OY. Количество юнитов в единице шкалы.
    Dim intScaleStepCount As Integer    'Вспомогательная переменная, минимальное количество единиц, которое покрывает величину траффика

    Set curPage = thisDoc.Page(1)

    i=1
    Set DiagramDayShape = Nothing
    Set LegendShape = Nothing
    'Ищем в документе необходимые шэйпы, в которых должны быть созданы диаграммы на каждый день и на весь месяц.
    Do While i <= curPage.ShapesNum()
        if curPage.Shape(i).Name = "DiagramDay" Then
            Set DiagramDayShape = curPage.Shape(i)
        End If
        if curPage.Shape(i).Name = "DiagramSum" Then
            Set DiagramSumShape = curPage.Shape(i)
        End If
        i=i+1
    Loop
    strLostShapesName = ""
    If DiagramDayShape = Nothing Then
        strLostShapesName = "DiagramDay"
    End If
    If DiagramSumShape = Nothing Then
        strLostShapesName = "DiagramSum"
    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-шэйпов. Остаются только оси и их подписи.
    'Поскольку после удаления одного шэйпа индексы остальных автоматически пересчитываются,
    'чтобы заполнить выпавший индекс, перебор элементов начинается с наибольшего индекса.
    For i=DiagramDayShape.ShapesNum() To 1 Step -1
        If DiagramDayShape.Shape(i).Name <> "DescX" And DiagramDayShape.Shape(i).Name <> "DescY" And DiagramDayShape.Shape(i).Name <> "OX" And DiagramDayShape.Shape(i).Name <> "OY" Then
            DiagramDayShape.RemoveShape(i)
        End If
    Next
    For i=DiagramSumShape.ShapesNum() To 1 Step -1
        If DiagramSumShape.Shape(i).Name <> "DescX" And DiagramSumShape.Shape(i).Name <> "DescY" And DiagramSumShape.Shape(i).Name <> "OX" And DiagramSumShape.Shape(i).Name <> "OY" Then
            DiagramSumShape.RemoveShape(i)
        End If
    Next

    'График на каждый день месяца.
    'Вычисляем параметры оси OY - масштаб, количество наносимых делений, количество единиц,
    'которые изображает каждое деление.
    dblStepScale = CalcScaleStep(dblMaxDayTraffic)
    intScaleStepCount = dblMaxDayTraffic \ dblStepScale + 1
    Select Case intScaleStepCount
    Case 1 To 25
        dblMaxY = 25
        intStep = 1
        dblScale = 100
    Case 26 To 50
        dblMaxY = 50
        intStep = 1
        dblScale = 50
    Case 51 To 75
        dblMaxY = 75
        intStep = 3
        dblScale = 33.33333
    Case Else
        dblMaxY = 100
        intStep = 2
        dblScale = 25
    End Select

    'Рисуем график траффика за каждый день месяца
    dblDiagHeight = DiagramDayShape.Height
    Set LineShape = DiagramDayShape.BeginShape()
    LineShape.PenColor.Index = 12
    LineShape.PenWeight = 6
    DiagramDayShape.MoveTo(0, dblDiagHeight)
    DiagramDayShape.LineTo(0, dblDiagHeight - adValues(0)*dblScale)
    For i=1 To intMaxX - 1
        DiagramDayShape.LineTo(i*condblXScale, dblDiagHeight - adValues(i)*dblScale/dblStepScale)
    Next
    DiagramDayShape.LineTo((intMaxX-1)*condblXScale, dblDiagHeight)
    DiagramDayShape.LineTo(0, dblDiagHeight)
    LineShape.FillPattern = 1
    LineShape.FillColor.Index = 12
    DiagramDayShape.EndShape()
    'Наносим шкалу на ось OY
    For i=intStep To dblMaxY Step intStep
        'Штрих оси OY
        DiagramDayShape.DrawLine(-10, dblDiagHeight - i*dblScale, 10, dblDiagHeight - i*dblScale)
        'Подпись возле штриха
        DrawTextBox(DiagramDayShape, -150, dblDiagHeight - i*dblScale - 25, -20, dblDiagHeight - i*dblScale + 25, CStr(dblStepScale * i), 10, 0, 2)
    Next
    'Наносим шкалу на ось OX
    For i=2 To intMaxX
        DiagramDayShape.DrawLine((i-1)*condblXScale, dblDiagHeight + 10, (i-1)*condblXScale, dblDiagHeight - 10)
        DrawTextBox(DiagramDayShape, (i-1)*condblXScale-25, dblDiagHeight + 20, (i-1)*condblXScale+25, dblDiagHeight+70, CStr(i), 10, 0, 1)
    Next


    'График суммарного траффика с начала месяца.
    'Вычисляем параметры оси OY - масштаб, количество наносимых делений, количество единиц,
    'которые изображает каждое деление.
    dblStepScale = CalcScaleStep(dblMonthTraffic)
    intScaleStepCount = dblMaxDayTraffic \ dblStepScale + 1
    Select Case intScaleStepCount
    Case 1 To 25
        dblMaxY = 25
        intStep = 1
        dblScale = 100
    Case 26 To 50
        dblMaxY = 50
        intStep = 1
        dblScale = 50
    Case 51 To 75
        dblMaxY = 75
        intStep = 3
        dblScale = 100
    Case Else
        dblMaxY = 100
        intStep = 2
        dblScale = 50
    End Select
    dblDiagHeight = DiagramSumShape.Height
    dblSumTraffic = 0
    'Рисуем график суммарного траффика с начала месяца
    Set LineShape = DiagramSumShape.BeginShape()
    LineShape.PenColor.Index = 12
    LineShape.PenWeight = 6
    DiagramSumShape.MoveTo(0, dblDiagHeight)
    For i=0 To intMaxX - 1
        dblSumTraffic = dblSumTraffic + adValues(i)
        DiagramSumShape.LineTo((i+1)*condblXScale, dblDiagHeight - dblSumTraffic*dblScale/dblStepScale)
    Next
    DiagramSumShape.LineTo(intMaxX*condblXScale, dblDiagHeight)
    DiagramSumShape.LineTo(0, dblDiagHeight)
    LineShape.FillPattern = 1
    LineShape.FillColor.Index = 12
    DiagramSumShape.EndShape()
    'Наносим шкалу на ось OY
    For i=intStep To dblMaxY Step intStep
        DiagramSumShape.DrawLine(-10, dblDiagHeight - i*dblScale, 10, dblDiagHeight - i*dblScale)
        DrawTextBox(DiagramSumShape, -150, dblDiagHeight - i*dblScale - 25, -20, dblDiagHeight - i*dblScale + 25, CStr(dblStepScale * i), 10, 0, 2)
    Next
    'Наносим шкалу на ось OX
    For i=1 To intMaxX
        DiagramSumShape.DrawLine(i*condblXScale, dblDiagHeight + 10, i*condblXScale, dblDiagHeight - 10)
        DrawTextBox(DiagramSumShape, i*condblXScale-25, dblDiagHeight + 20, i*condblXScale+25, dblDiagHeight+70, CStr(i), 10, 0, 1)
    Next



    i=1
    Set FileNameProp = Nothing
    'Проверяем, есть ли в диаграмме CustomProperty с именем файла-источника данных.
    'Если есть, помещаем в него имя последнего использовавшегося файла.
    Do While i<=DiagramDayShape.CustomPropsNum() And FileNameProp = Nothing
        If DiagramDayShape.CustomProp(i).Label = "LastSourceFileName" Then
            Set FileNameProp = DiagramDayShape.CustomProp(i)
        End If
        i = i + 1
    Loop
    'Если такого CustomProperty не найдено, создаем его сами.
    If FileNameProp = Nothing Then
        Set FileNameProp = DiagramDayShape.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 - стиль шрифта
'intHAlign - горизонтальное выравнивание текста
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, ByVal intHAlign As Byte) 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)
    DrawTextBox.SetParaHAlign(1, Len(strText), intHAlign)
End Function

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

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