'Begin Description 'Назначение: В назначенном окне результатов скрипт ищет мобильную таблицу "Coordinates of the Curve" (координаты кривых) ' (результат ROC-анализа). В случае нахождения - создаёт новую таблицу, называет её ' "Coordinates (with test)", копирует туда содержимое найденной таблицы и дополняет ' новую таблицу столбцом со статистикой Sensitivity + (1-(1-Specificity)). 'Условия: нужные таблицы находятся в назначенном окне результатов. 'End Description 'Автор: Raynald Levesque, rlevesque@videotron.ca, 21.10.2000. 'Размещение: http://www.spsstools.ru/Scripts/PivotTables/CreatePivotTable-ROCsbs.txt (.sbs). 'Перевод: А. Балабанов, 11.01.2009. 'Проверено: SPSS 15.0.0. 'Константы уровня скрипта Option Explicit Const cNEWTABLE As String = "Coordinates (with test)" '******************************************** Sub main() ' Поиск всех таблиц с названием "Coordinates of the Curve" ' Вызов процедуры InsertROCTable для каждой найденной таблицы. Dim objOutputDoc As ISpssOutputDoc Dim objOutputItems As ISpssItems Dim objOutputItem As ISpssItem Dim objPivotTable As PivotTable On Error GoTo errHand 'Продолжаем выполнение программы только если есть окно результатов If objSpssApp.Documents.OutputDocCount > 0 Then 'Установление ссылки на коллекцию объектов из назначенного (designated) окна результатов Set objOutputItems = objSpssApp.GetDesignatedOutputDoc.Items Else MsgBox "Не найдено окно результатов!" Exit Sub End If Dim intItemType As Integer 'тип объекта (см. свойство SpssType) Dim strLabel As String 'метка объекта Dim intIndex As Integer 'индекс (порядковый номер) объекта Dim intMax As Integer 'число объектов в окне результатов (Output Window) ' Пробежка по всем объектам ' Вызов процедуры InsertROCTable, если тип объекта - PivotTable, а метка - "Coordinates of the Curve" intIndex = 0 intMax = objOutputItems.Count() Do Set objOutputItem = objOutputItems.GetItem(intIndex) intItemType = objOutputItem.SPSSType() strLabel = objOutputItem.Label If (intItemType = SPSSPivot) * (strLabel="Coordinates of the Curve") Then Set objPivotTable = objOutputItem.Activate() Debug.Print "В процедуре Main: вызов InsertROCTable";intIndex;strLabel;intMax Call InsertROCTable(objPivotTable,intIndex) objOutputItem.Deactivate intMax = intMax + 1 '(после отработки процедуры в окне стало на 1 объект больше) intIndex = intIndex + 1 'пропуск только что созданной таблицы End If ' Debug.Print "В процедуре Main: ";intIndex;strLabel;intMax intIndex = intIndex + 1 Loop While intIndex < intMax Exit Sub errHand: MsgBox( "Ошибка: " &Err.Number &" Описание: "&Err.Description,1,"Ошибка в скрипте CreatePivotTable(ROC)") Stop End Sub '***************************************************** Sub InsertROCTable(objPivotTable0 As PivotTable,intIndex As Integer) ' Процедура создаёт новую таблицу сразу после таблицы "Coordinates of the Curve". ' Новая таблица имеет размер найденной таблицы, увеличенный на 1 колонку. Dim objOutputDoc As ISpssOutputDoc Dim objItems As ISpssItems Dim objItem As ISpssItem Dim objPivotTable As PivotTable 'Новая таблица Dim objDataCells As ISpssDataCells Dim objDataCells0 As ISpssDataCells Dim objColumnLabels0 As ISpssLabels Dim objColumnLabels As ISpssLabels Dim objRowLabels0 As ISpssLabels Dim objRowLabels As ISpssLabels Dim objLayerLabels0 As ISpssLayerLabels Dim objLayerLabels As ISpssLayerLabels Dim objPivMgr As ISpssPivotMgr Dim objPivMgr0 As ISpssPivotMgr Dim objLayerDim As ISpssDimension Dim objLayerDim0 As ISpssDimension Dim objRowDim0 As ISpssDimension Dim lngIndex As Long Dim intRow As Integer Dim intCol As Integer Dim intLay As Integer Dim intR As Integer ' Счётчик цикла Dim intC As Integer ' Счётчик цикла Dim intL As Integer ' Счётчик цикла Dim nItems As Integer On Error GoTo errHandler Set objOutputDoc = objSpssApp.GetDesignatedOutputDoc Set objDataCells0 = objPivotTable0.DataCellArray Set objPivMgr0 = objPivotTable0.PivotManager Set objLayerDim0 = objPivMgr0.LayerDimension(0) ' Поиск размерности строк с меткой "Test Result Variable(s)", и поворот размерности в ' размерность первого слоя. Наверняка этой операции можно избежать, но я не нашёл, как :-( intRow = objPivMgr0.NumRowDimensions For intR = 0 To intRow -1 Set objRowDim0 = objPivMgr0.RowDimension(intR) If objRowDim0.DimensionName = "Test Result Variable(s)" Then objRowDim0.MoveToLayer(0) Exit For End If Next 'Определение размеров исходной таблицы intLay = objLayerDim0.NumCategories intRow = objDataCells0.NumRows intCol = objDataCells0.NumColumns ' Debug.Print intRow;intCol;intLay ' Вставляем пустую таблицу с требуемым количеством строк, столбцов, слоев ' Дополнительная колонка - для информации о тесте lngIndex = objOutputDoc.InsertTable( cNEWTABLE, intRow, intCol+1,intLay) Set objItems = objOutputDoc.Items ' установление ссылки и активация новой таблицы Set objItem = objItems.GetItem(intIndex + 1) Set objPivotTable = objItem.Activate objPivotTable.UpdateScreen = False objPivotTable.TitleText = objPivotTable0.TitleText 'получение информации, которая должна быть скопирована в новую таблицу (objPivotTable) Set objColumnLabels0 = objPivotTable0.ColumnLabelArray() ' Установка меток столбцов Set objColumnLabels = objPivotTable.ColumnLabelArray() objColumnLabels.ValueAt(0,0) = objColumnLabels0.ValueAt(0,0) For intC = 0 To intCol - 1 objColumnLabels.ValueAt(1,intC) = objColumnLabels0.ValueAt(1,intC) Next ' Добавление метки к последнему столбцу objColumnLabels.ValueAt(1,intCol) = "Sensitivity + (1-(1-Spec.))" ' Установка метки размерности слоев Set objPivMgr = objPivotTable.PivotManager Set objLayerDim = objPivMgr.LayerDimension(0) objLayerDim.DimensionName = "Test Result Variable(s)" With objDataCells0 For intL = intLay -1 To 0 Step -1 objLayerDim0.CurrentCategory = intL objLayerDim.CurrentCategory = intL Set objLayerLabels0 = objPivotTable0.LayerLabelArray() Set objLayerLabels = objPivotTable.LayerLabelArray() ' Установка меток для отдельных слоев objLayerLabels.ValueAt(0,2)=objLayerLabels0.ValueAt(0,2) 'Получение ссылки на пустые ячейки данных в новой таблице Set objDataCells = objPivotTable.DataCellArray Set objDataCells0 = objPivotTable0.DataCellArray 'Заполнение данными новой таблицы For intC = 0 To intCol For intR = 0 To intRow - 1 If intC < intCol Then 'Копируем данные из исходной таблицы objDataCells.ValueAt(intR,intC) = Format(.ValueAt(intR,intC),"#.000") Else 'Вычисление новой колонки с тестом objDataCells.ValueAt(intR,intC) = Format(.ValueAt(intR,intC-2)+1-.ValueAt(intR,intC-1),"#.000") End If objDataCells.SelectCellAt(intR, intC) Next intR Next intC Next intL End With 'установка формата отображения с 3 знаками после запятой '### Текстовый формат в оригинальном коде ("3") исправлен на числовой (3) - А.Б. objPivotTable.NumericFormat("#,###.##",3) ' Поиск размерности слоёв с меткой "Test Result Variable(s)" и поворот её ' в первую размерность строк: intLay = objPivMgr.NumLayerDimensions For intL = 0 To intLay -1 Set objLayerDim = objPivMgr.LayerDimension(intL) If objLayerDim.DimensionName = "Test Result Variable(s)" Then objLayerDim.MoveToRow(0) Exit For End If Next For intL = 0 To intLay -1 Set objLayerDim0 = objPivMgr0.LayerDimension(intL) If objLayerDim0.DimensionName = "Test Result Variable(s)" Then objLayerDim0.MoveToRow(0) Exit For End If Next 'Обновление (перерисовка с автоподгонкой) обеих таблиц Set objItem = objItems.GetItem(intIndex) Set objPivotTable = objItem.Activate objPivotTable.Autofit objPivotTable.UpdateScreen=True Set objItem = objItems.GetItem(intIndex+1) Set objPivotTable = objItem.Activate objPivotTable.Autofit objPivotTable.UpdateScreen=True objItem.Deactivate Exit Sub errHandler: MsgBox ("Ошибка: " & Err.Number & " Описание: " & Err.Description,1,"Ошибка в скрипте CreatePivotTable(ROC)") Stop End Sub