'Title: 'Italize percentages in Pivot Tables 'Begin Description 'Italize percentages contained in all Pivot Tables. See the 4 constants defined 'after the Option Explicit for other fonts options 'Script can also be used to change background color of those cells 'Posted to SPSSX-L list by Raynald Levesque on 2004/11/13 'End Description Option Explicit 'Use of of the following constants in the "Call ChangeTextStyle()" line Const cNORMAL=0 Const cITALIC=1 Const cBOLD=2 Const cBOLDITALIC=3 Option Explicit Sub Main Dim objPivot As PivotTable Dim objItem As ISpssItem Do While GetNextPivot(objPivot, objItem) 'postpone drawing until we're finished objPivot.UpdateScreen = False Call ChangeTextStyle(objPivot, "%", cITALIC, vbWhite) 'Call ChangeTextStyle(objPivot, "%", cNORMAL, vbYellow) objPivot.UpdateScreen = True objPivot.Autofit objItem.Deactivate objItem.ActivateTable 'to ensure table is updated correctly objItem.Deactivate 'to ensure table is updated correctly Loop End Sub Sub ChangeTextStyle(objPivot As PivotTable, strNeedle As String , intTextStyle As Integer, lngBackColor As Long) Dim lngRow As Long, lngCol As Long Dim objDataCells As ISpssDataCells Dim strFormat As String Set objDataCells = objPivot.DataCellArray With objDataCells For lngRow = 0 To .NumRows - 1 For lngCol = 0 To .NumColumns - 1 strFormat = .NumericFormatAt(lngRow,lngCol) If Not IsNull (.ValueAt (lngRow, lngCol)) And InStr(strFormat,strNeedle)>0 Then .TextStyleAt(lngRow,lngCol)= intTextStyle .BackgroundColorAt(lngRow,lngCol)= lngBackColor End If Next Next End With objPivot.Autofit End Sub Function GetNextPivot(objPivot As PivotTable, objItem As ISpssItem) 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 'This sub was written by SPSS 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 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