|
Для того, чтобы был понятен смысл того, что хочется сделать, - краткое вступление.
Слона, зебру, кошку и крысу кормили в течение года. Каждый месяц их взвешивали. Получили некоторые наборы данных, которые пожелали отразить на диаграмме. Очевидно, что порядки этих чисел существенно разнятся. Если делать абсолютную диаграмму, то на фоне слона и зебры кошка с крысой просто потеряются. Желательно иметь две оси значений (естественно, с разным масштабом). На одной значения будут отражать слона с зеброй, на другой – кошку с крысой. Данные на диаграмму добавляются без проблем. Каким-то образом нужно объединить в некоторую общность ряды данных слона и зебры, а также кошки и крысы. В качестве таких пробных общностей выступали SeriesCollection, ChartGroup, но результаты что-то не порадовали. В моем случае такая же задача ставится по содержанию химических веществ в воде, содержание которых между собой разнится примерно как вышеупомянутые животные. Далее привожу фрагмент кода (кое-что пока с rem, но это неважно):
Public Sub CreateDiscretChart()
Dim rst As DAO.Recordset
Dim dbs As DAO.Database
Dim frmResultAnaliz As Form
Dim frmResultAnalizTabl As Form
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlChart As Excel.Chart
Dim co As ChartObject
Dim cw As Long, rh As Long
Dim strWhere As Variant
Dim i As Integer
Dim mdl As Module
Dim diagSheetName As String
Dim strWhereDate1 As String
Dim strWhereDate2 As String
Dim strWherePredpr As String
Dim strWhereDate As Variant
Dim r As Long
Dim X As Long
Dim a As Long
Dim rng As Range
Dim y As String
'Этот фрагмент можно активировать для проверки типа (DAO или ADO) набора записей
Rem Dim rs As Object
Rem Set rs = Forms("frmResultAnalizTabl").Recordset
Rem If TypeOf rs Is DAO.Recordset Then
Rem MsgBox "DAO Recordset"
Rem ElseIf TypeOf rs Is ADODB.Recordset Then
Rem MsgBox "ADO Recordset"
Rem End If
'On Error GoTo HandleErr
'Формирование имен для книги, листа и заголовка диаграммы
'по выбранным датам
strWhereDate1 = Forms!frmAnalizData!txtDateBegin.Value
strWhereDate2 = Forms!frmAnalizData!txtDateEnd.Value
'по выбранному предприятию
strWherePredpr = Forms!frmAnalizData.Controls!cboPredpr.Value
'Задание имен для книги, листа и заголовка диаграммы
diagSheetName = strWherePredpr & " с " & strWhereDate1 & " по " & strWhereDate2
'Создание объекта Application для Excel
Set xlApp = New Excel.Application
xlApp.Visible = True
'Создание новой книги
Set xlBook = xlApp.Workbooks.Add
'удаление всех листов кроме одного
xlApp.DisplayAlerts = False
For i = xlBook.Worksheets.Count To 2 Step -1
xlBook.Worksheets(i).Delete
Next i
xlApp.DisplayAlerts = True
'получение ссылки на первый лист
Set xlSheet = xlBook.ActiveSheet
'переименование первого листа
xlSheet.Name = diagSheetName
'создание набора записей из формы "Результаты анализа" на лист Excel
Set dbs = CurrentDb
Set rst = Forms("frmResultAnalizTabl").Recordset
rst.MoveFirst
'перенос заголовков столбцов на лист
With xlSheet
With .Cells(1, 1)
Rem.Value = rst.Fields(0).Name
.Value = "счетчик"
Rem.Font.Bold = True
End With
With .Cells(1, 2)
Rem.Value = rst.Fields(1).Name
.Value = "предприятие"
Rem.Font.Bold = True
End With
With .Cells(1, 3)
Rem.Value = rst.Fields(2).Name
.Value = "Дата"
.Font.Bold = True
End With
With .Cells(1, 4)
Rem.Value = rst.Fields(3).Name
.Value = "рН"
.Font.Bold = True
End With
With .Cells(1, 5)
Rem.Value = rst.Fields(4).Name
.Value = "Сух ост"
.Font.Bold = True
End With
With .Cells(1, 6)
Rem.Value = rst.Fields(5).Name
.Value = "Аммоний"
.Font.Bold = True
End With
With .Cells(1, 7)
Rem.Value = rst.Fields(6).Name
.Value = "Нитриты"
.Font.Bold = True
End With
With .Cells(1, 8)
Rem.Value = rst.Fields(7).Name
.Value = "Нитраты"
.Font.Bold = True
End With
With .Cells(1, 9)
Rem.Value = rst.Fields(8).Name
.Value = "Железо"
.Font.Bold = True
End With
With .Cells(1, 10)
Rem.Value = rst.Fields(9).Name
.Value = "Фосфаты"
.Font.Bold = True
End With
With .Cells(1, 11)
Rem.Value = rst.Fields(10).Name
.Value = "Хлориды"
.Font.Bold = True
End With
With .Cells(1, 12)
Rem.Value = rst.Fields(11).Name
.Value = "Сульфаты"
.Font.Bold = True
End With
With .Cells(1, 13)
Rem.Value = rst.Fields(12).Name
.Value = "АПАВ"
.Font.Bold = True
End With
With .Cells(1, 14)
Rem.Value = rst.Fields(13).Name
.Value = "Нефтепродукты"
.Font.Bold = True
End With
With .Cells(1, 15)
Rem.Value = rst.Fields(14).Name
.Value = "Взв в-ва"
.Font.Bold = True
End With
With .Cells(1, 16)
Rem.Value = rst.Fields(15).Name
.Value = "Медь"
.Font.Bold = True
End With
With .Cells(1, 17)
Rem.Value = rst.Fields(16).Name
.Value = "Марганец"
.Font.Bold = True
End With
With .Cells(1, 18)
Rem.Value = rst.Fields(17).Name
.Value = "ХПК"
.Font.Bold = True
End With
End With
'копирование содержимого формы frmAnalizDataTabl на лист Excel
xlApp.Range("A2").CopyFromRecordset rst
'удаление двух левых столбцов (счетчик и название предприятия)
Range(Columns(1), Columns(2)).Delete (xlShiftToLeft)
'подгонка ширины столбцов по содержимому
With xlSheet
.Columns(1).AutoFit
.Columns(2).AutoFit
.Columns(3).AutoFit
.Columns(4).AutoFit
.Columns(5).AutoFit
.Columns(6).AutoFit
.Columns(7).AutoFit
.Columns(8).AutoFit
.Columns(9).AutoFit
.Columns(10).AutoFit
.Columns(11).AutoFit
.Columns(12).AutoFit
.Columns(13).AutoFit
.Columns(14).AutoFit
.Columns(15).AutoFit
.Columns(16).AutoFit
End With
'Построение диаграммы
Set xlChart = xlApp.Charts.Add
'задание диапазона для диаграммы от ячейки A1 до
'пересечения первой пустой строки и 17-го столбца. Для этого производится
'поиск первой пустой ячейки в первом столбце (который всегда заполнен, т.к.
'это даты), а затем значение строки присваивается значению строки ячейки
'в 17-м столбце
With xlChart
.ChartType = xlLine
For r = 1 To 10000
If IsEmpty(xlSheet.Cells(r, 1)) Then
Let a = r - 1
Exit For
End If
Next r
Rem .SetSourceData Source:=xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(a, 16)), PlotBy:=xlColumns
End With
'получение данных для размещения диаграммы
Rem cw = Columns(1).Width
Rem rh = Rows(1).Height
'размещение диаграммы с применением ширины столбцов и высоты строк в качестве
'единиц измерения
Rem Set co = ActiveSheet.ChartObjects(cw * 3, rh * 0.5, cw * 8, rh * 20)
'переименование книги
Rem Workbooks("Book1.xls").Worksheets("xlSheet").Names.Add Name:="diagSheetName", RefersTo:="=xlSheet!$A$1:$B$1"
'Добавление рядов данных
'добавление рядов данных для ингредиентов,
'имеющих порядок концентраций ~ от 0,01 до 100 мг/дм3
Rem Rem xlChart.SeriesCollection (1)
xlChart.ChartType = xlLine
xlChart.SeriesCollection (1)
Rem xlChart.ChartGroups
'добавление ряда данных для рН
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 2), xlSheet.Cells(a, 2)), Rowcol:=xlColumns
'добавление ряда данных для аммония
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 4), xlSheet.Cells(a, 4)), Rowcol:=xlColumns
'добавление ряда данных для нитритов
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 5), xlSheet.Cells(a, 5)), Rowcol:=xlColumns
'добавление ряда данных для нитратов
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 6), xlSheet.Cells(a, 6)), Rowcol:=xlColumns
'добавление ряда данных для железа
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 7), xlSheet.Cells(a, 7)), Rowcol:=xlColumns
'добавление ряда данных для фосфатов
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 8), xlSheet.Cells(a, 8)), Rowcol:=xlColumns
'добавление ряда данных для АПАВ
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 11), xlSheet.Cells(a, 11)), Rowcol:=xlColumns
'добавление ряда данных для нефтепродуктов
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 12), xlSheet.Cells(a, 12)), Rowcol:=xlColumns
'добавление ряда данных для меди
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 14), xlSheet.Cells(a, 14)), Rowcol:=xlColumns
'добавление ряда данных для марганца
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 15), xlSheet.Cells(a, 15)), Rowcol:=xlColumns
'добавление ряда данных для ХПК
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 16), xlSheet.Cells(a, 16)), Rowcol:=xlColumns
'добавление рядов данных для ингредиентов,
'имеющих порядок концентраций ~ от 10 до 5000 мг/дм3
xlChart.SeriesCollection (2)
Rem xlChart.ChartGroups
Rem xlChart.ChartType = xlLine
'добавление ряда данных для сухого остатка
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 3), xlSheet.Cells(a, 3)), Rowcol:=xlColumns
'добавление ряда данных для взвешенных веществ
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 13), xlSheet.Cells(a, 13)), Rowcol:=xlColumns
'добавление ряда данных для сульфатов
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 10), xlSheet.Cells(a, 10)), Rowcol:=xlColumns
'добавление ряда данных для хлоридов
xlChart.SeriesCollection.Add Source:=xlSheet.Range(xlSheet.Cells(1, 9), xlSheet.Cells(a, 9)), Rowcol:=xlColumns
With xlChart.SeriesCollection(1)
'первичная ось значений для ингредиентов,
'имеющих порядок концентраций ~ от 0,01 до 100 мг/дм3
xlChart.HasAxis(xlValue, xlPrimary) = True
With xlChart.Axes(xlValue, xlPrimary)
.HasTitle = True
.MajorUnit = 1
.MinorUnit = 0.1
With xlChart.Axes(xlValue, xlPrimary).AxisTitle
.Caption = "N-группа, Fe, PO4, Cl, АПАВ, Н/П, Cu, Mn"
.Font.Size = 8
Rem Rem .Orientation = xlHorizontal
.Characters(14, 4).Font.Italic = True
.Border.Weight = xlMedium
End With
End With
End With
With xlChart.SeriesCollection(2)
'вторичная ось значений для ингредиентов,
'имеющих порядок концентраций ~ от 10 до 5000 мг/дм3
xlChart.HasAxis(xlValue, xlSecondary) = True
With xlChart.Axes(xlValue, xlSecondary)
.HasTitle = True
.MajorUnit = 100
.MinorUnit = 10
With xlChart.Axes(xlValue, xlSecondary).AxisTitle
.Caption = "Cl, сух ост, взв в-ва, SO4"
.Font.Size = 8
Rem .Orientation = xlVertical
.Characters(14, 4).Font.Italic = True
.Border.Weight = xlMedium
End With
End With
End With
'Задание свойств диаграммы
With xlBook.ActiveChart
.HasTitle = True
.HasLegend = True
With .ChartTitle
.Characters.Text = diagSheetName & " диаграмма"
.Font.Size = 16
Rem .Shadow = True
.Border.LineStyle = xlSolid
End With
'добавление осей и форматирование подписей к ним
'первичная ось категорий (дата)
.HasAxis(xlCategory, xlPrimary) = True
With xlChart.Axes(xlCategory, xlPrimary)
.HasTitle = True
.MajorTickMark = xlTickMarkCross
.TickLabelPosition = xlTickLabelPositionNextToAxis
.TickLabels.Font.Size = 8
With xlChart.Axes(xlCategory, xlPrimary).AxisTitle
.Caption = "Дата"
.Orientation = xlHorizontal
.Border.Weight = xlMedium
End With
End With
'вторичная ось категорий отсутствует
.HasAxis(xlCategory, xlSecondary) = False
End With
xlApp.Visible = True
'формирование линий сетки
Rem xlChart.Axes(xlValue).HasMajorGridlines = True
Rem xlChart.Axes(xlCategory).HasMajorGridlines = True
Rem xlChart.Axes(xlValue).HasMinorGridlines = True
Rem xlChart.Axes(xlCategory).HasMinorGridlines = True
'заполнение области диаграммы белым цветом
Rem xlChart.ChartArea.Interior.Color = RGB(255, 255, 255)
'заполнение области графика белым цветом
Rem xlChart.PlotArea.Interior.Color = RGB(255, 255, 255)
ExitHere:
On Error Resume Next
rst.Close
Set rst = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Exit Sub
HandleErr:
MsgBox Err & ": " & Err.Description, , "Ошибка в диаграмме"
Resume ExitHere
Resume
End Sub
|
