'Begin Description 'Purpose: Finds "Coordinates of the Curve" Pivot Table in the Desiganted Output ' Copy the table To a table named "Coordinates (with test)" ' Add a column to the new table, that table contains the numbers ' Sensitivity + (1-(1-Specificity)) 'Assumptions: A designated output exists. 'End Description 'Raynald Levesque rlevesque@videotron.ca 2000/10/21 'Script level constant Option Explicit Const cNEWTABLE As String = "Coordinates (with test)" '******************************************** Sub main() ' Locates all tables named "Coordinates of the Curve" ' Call InsertROCTable after each find. Dim objOutputDoc As ISpssOutputDoc Dim objOutputItems As ISpssItems Dim objOutputItem As ISpssItem Dim objPivotTable As PivotTable On Error GoTo errHand 'Continue only if an output document exists. If objSpssApp.Documents.OutputDocCount > 0 Then 'Get the currently designated output document items collection. Set objOutputItems = objSpssApp.GetDesignatedOutputDoc.Items Else MsgBox "There are no Output window!" Exit Sub End If Dim intItemType As Integer 'type of item (see SpssType property) Dim strLabel As String 'Item label Dim intIndex As Integer 'index of current item Dim intMax As Integer 'Number of itme in Output Window ' Iterate through output items ' Call InsertROCTable if Type=PivotTable and Label="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 "In Sub Main: Call InsertROCTable";intIndex;strLabel;intMax Call InsertROCTable(objPivotTable,intIndex) objOutputItem.Deactivate intMax = intMax + 1 'There is now one more itme in the output window intIndex = intIndex + 1 'Skip the table which was just created End If ' Debug.Print "In Sub Main: ";intIndex;strLabel;intMax intIndex = intIndex + 1 Loop While intIndex < intMax Exit Sub errHand: MsgBox( "err= " &Err.Number &" Description= "&Err.Description,1,"MsgBox") Stop End Sub '***************************************************** Sub InsertROCTable(objPivotTable0 As PivotTable,intIndex As Integer) ' This sub creates a new pivot table immediately after the table "Coordinates of the Curve" ' The new table has same dimensions as original PT but with 1 more column. Dim objOutputDoc As ISpssOutputDoc Dim objItems As ISpssItems Dim objItem As ISpssItem Dim objPivotTable As PivotTable 'The new table 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 ' Loop Counter Dim intC As Integer ' Loop Counter Dim intL As Integer ' Loop Counter 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) ' Search for the Row dimension named "Test Result Variable(s)" and pivot it ' To the first layer dimension. There is certainly a way to avoid this ' but I have not found it :-( 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 'Get dimensions of original table intLay = objLayerDim0.NumCategories intRow = objDataCells0.NumRows intCol = objDataCells0.NumColumns ' Debug.Print intRow;intCol;intLay ' Insert a blank table with the required nb of rows, columns and layers ' The extra column is for the test column lngIndex = objOutputDoc.InsertTable( cNEWTABLE, intRow, intCol+1,intLay) Set objItems = objOutputDoc.Items ' Get and activate the new table Set objItem = objItems.GetItem(intIndex + 1) Set objPivotTable = objItem.Activate objPivotTable.UpdateScreen = False objPivotTable.TitleText = objPivotTable0.TitleText 'Get info which is to be copied into the new objPivotTable Set ObjColumnLabels0 = objPivotTable0.ColumnLabelArray() ' Set column labels 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 ' Add label for the test column objColumnLabels.ValueAt(1,intCol) = "Sensitivity + (1-(1-Spec.))" ' Set layer dimension name 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() ' Set layer labels objLayerLabels.ValueAt(0,2)=objLayerLabels0.ValueAt(0,2) 'Get empty data cells of the layer of the new PivotTable Set objDataCells = objPivotTable.DataCellArray Set objDataCells0 = objPivotTable0.DataCellArray 'Populate the new PivotTable For intC = 0 To intCol For intR = 0 To intRow - 1 If intC < intCol Then 'Copy data from original table objDataCells.ValueAt(intR,intC) = Format(.ValueAt(intR,intC),"#.000") Else 'Calculate the new test column 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 'set display format of selected cells to 3 decimal places objPivotTable.NumericFormat("#,###.##","3") ' Search for the Layer dimension named "Test Result Variable(s)" and pivot it ' To the first row dimension: 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 'Refresh the 2 pivot table 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= " & Err.Number & " Description= " & Err.Description,1,"Error in CreatePivotTable(ROC)") Stop End Sub