' Highlight significant cells of all ANOVA tables in the Designated Viewer. ' Writen for Manfred Straehle by Raynald Levesque on 2004/01/30. Sub Main Dim objPivot As PivotTable Dim objItem As ISpssItem Dim strLabel As String strLabel="ANOVA" Do While GetNextPivot(objPivot, objItem, strLabel) Call Highlight(objPivot, objItem) Loop End Sub '################## Const cSigVal=.005 '################## Const TextTotalStr ="Sig." Const cGREEN = RGB(60, 179, 113) Const cWHITE = RGB(255,255,255) Sub Highlight(objPivotTable As PivotTable , objItem As ISpssItem) Dim strSigVal As String ' A navigator item. Dim bolPivotSelected As Boolean Dim s_bolCellsSelected As Boolean 'global variable that keeps track of whether any cells are selected from searching s_bolCellsSelected = False Dim objDataCells As ISpssDataCells Dim lngNumRows As Long Dim lngNumColumns As Long Set objDataCells = objPivotTable.DataCellArray ' Loop through the cells and shades those cells with values less than cSigVal: Dim objRowLabels As ISpssLabels ' Row Label array. Set objRowLabels = objPivotTable.RowLabelArray Dim objColLabels As ISpssLabels ' Col Label array. Set objColLabels = objPivotTable.ColumnLabelArray lngNumRows = objDataCells.NumRows lngNumColumns = objDataCells.NumColumns Dim I As Integer, J As Integer objItem.Deactivate For I = 0 To lngNumRows -1 Dim dummy As Integer For J = 0 To lngNumColumns -1 If InStr (objColLabels.ValueAt(objColLabels.NumRows-1,J), TextTotalStr)> 0 Then If Len(objDataCells.ValueAt (I,J)) > 0 Then If objDataCells.ValueAt (I,J) <= cSigVal Then objDataCells.BackgroundColorAt (I,J) = cGREEN Else objDataCells.BackgroundColorAt (I,J) = cWHITE End If Else objDataCells.BackgroundColorAt (I,J) = cWHITE End If End If Next Next ' Deactivate the pivot table and exit objItem.Activate objItem.Deactivate End Sub Function GetNextPivot( objPivot As PivotTable, _ objItem As ISpssItem, _ strLabel As String ) As Boolean 'Purpose: Find each Pivot Table in turn 'Assumptions: A Pivot Table is in the Output Doc (Navigator); output doesn't change between calls 'Effects: each time the procedure is called, it activates the next selected Pivot Table 'Inputs: PivotTable object, Item object that contains selected PivotTable 'Return Values: activated PivotTable, Item in the Navigator, function value is True if a pivot table is found Static objDocuments As ISpssDocuments ' SPSS documents. Static objOutputDoc As ISpssOutputDoc ' Output document Static objItems As ISpssItems ' Output Navigator items Static intItem As Integer ' Output Navigator item's index Static intItemCount As Integer ' total number of items in the navigator Dim intItemType As Integer Dim bolSelected As Boolean ' True if an item is selected. Dim bolReset As Boolean Dim I As Integer ' initialize the return values GetNextPivot = False Set objPivot = Nothing Set objItem = Nothing ' if this is the first call, set a flag to initialize things If (objDocuments Is Nothing) Or (objOutputDoc Is Nothing) Or (objItems Is Nothing) Then bolReset = True End If If bolReset Then 'Get list of documents in SPSS. Set objDocuments = objSpssApp.Documents End If ' done with the document collection If bolReset Then ' Get designated document only if there is at least one output document. If objDocuments.OutputDocCount > 0 Then 'Get the currently designated output document. Set objOutputDoc = objSpssApp.GetDesignatedOutputDoc Else 'If no navigator window exists. MsgBox( "No navigator document found." ) Exit Function End If End If ' done with outputdoc ' Get the outline tree and the number of items: If bolReset Then Set objItems = objOutputDoc.Items intItemCount = objItems.Count End If ' there will be problems if anything failed, just make sure If (objDocuments Is Nothing) Or (objOutputDoc Is Nothing) Or (objItems Is Nothing) Then Debug.Print "objDocuments Is Nothing: " & (objDocuments Is Nothing) Debug.Print "objOutputDocIs Nothing: " & (objOutputDoc Is Nothing) Debug.Print "objItems Is Nothing: " & (objItems Is Nothing) MsgBox "There was a problem with the Navigator document.", vbExclamation, "GetNextPivot" Exit Function End If ' a simple check that output hasn't changed If intItemCount <> objItems.Count Then MsgBox "Output changed while Script was running.", vbExclamation, "GetNextPivot" Exit Function End If If bolReset Then intItem = 0 End If ' Get the next pivot table. For I = intItem To intItemCount - 1 Set objItem = objItems.GetItem(I) intItemType = objItem.SPSSType If intItemType = SPSSPivot And InStr(objItem.Label,strLabel)>0 Then intItem = I + 1 ' start here next time Set objPivot = objItem.ActivateTable() 'Activate the pivot table. GetNextPivot = True ' We did find a pivot table. Exit For ' Exit the loop. End If Next I If GetNextPivot = False And intItem = 0 Then 'No pivot table was found. MsgBox( "There are no Pivot Tables in the output." ) Exit Function End If End Function