'Begin Description 'This script allows a user to specify individual row label and column widths, by syntax, for pivot tables generated during an SPSS session. 'End Description ' 'REQUIREMENTS: ' SPSS Base Version 8.0 for Windows, or higher. ' 'PURPOSE: ' This script allows you to specify individual row label and column ' widths for any pivot table object generated during an SPSS session, ' by using syntax. You can specify widths in points or millimeters. This ' script also allows you to generate correct script syntax from a table ' you have manually altered so you don't have to calculate measurements. ' 'INPUTS: ' This script requires the column widths (and row widths if required) ' to be specified in a syntax window, where widths are separated ' (delimited) by a comma. Row label widths are delimited from ' column widths by the | character. Row label specifications ' are optional. See Applications A & B. ' ' This script also provides specifications derived from an existing ' pivot table for later application using syntax. See Application C. ' 'SPECIFICATIONS: ' ' SCRIPT file = 'filename' ('{units}{r1,r2,...,rn|}c1,c2,...,cn') ' ' Where units mm = millimeters [* default is points *] ' rn Width of row label column n [optional] ' cn Width of column n ' ' APPLICATION A: ' ' SCRIPT file="c:\\...\\spss\\scripts\\Table Widths - with Syntax.sbs" ("95,,95,,50"). ' ' This sets the first and third column widths to 95 points, and the fifth ' column to 50 points. The second, fourth and any additional columns ' remain unaltered. Specifications for columns that do not exist (e.g., ' a sixth value) are ignored. ' ' APPLICATION B: ' ' SCRIPT file="c:\\...\\spss\\scripts\\Table Widths - with Syntax.sbs" ("mm 80|,20,,35"). ' ' This sets the first column of row labels to 80 millimeters. The ' second column width of the table body is set to 20 millimeters, ' and the fourth to 35 millimeters. The first, third and all other ' columns in the table body remain unaltered. ' ' APPLICATION C: ' ' You can run this script from the Utilities>Run Script menu to generate ' syntax which replicates the current pivot table row and column label ' widths that you may have formatted manually. The resulting syntax is ' pasted into the designated Syntax Window. ' ' This script will also determine the necessary syntax to generate the ' selected table. Both output syntax and script syntax will be displayed ' in the designated syntax window. ' 'NOTES: ' Units are in points by default. You may specify millimeters (mm). ' ' The script selects and modifies the last pivot table object created ' prior to the script being executed. ' ' User specified widths of 0 will result in column being hidden. ' 'VERSION: ' Version : 1.1a ' Last Updated : 26 November 2001 ' 'AUTHOR: ' Name : Jason Burke, SPSS Australasia Pty Ltd. ' Telephone : +61 (0)2 9954 5660 ext 242 ' E-Mail : jburke AT spss DOT com ' Copyright : Copyright @ 1999 by Jason Burke. ' '***************************************************************************** 'Module level constants Const cSCRIPTNAME As String = "Table Widths - with syntax.sbs" Const cNONAVMSG As String = "No Viewer (output) document found." Const cNOPIVSELMSG As String = "Select Pivot Table before running this script." Public objPivotTable As PivotTable Sub Main 'String of column widths passed from syntax command Dim strParam As String Dim objItem As ISpssItem Dim bolFoundOutputDoc As Boolean Dim bolPivotSelected As Boolean Dim strFormatArray() As String Dim strColWidthArray() As String Dim strRowWidthArray() As String Dim strTableSyntaxArray() As String Dim intUnitSize As Long Dim intDelimiter As Integer Dim intNumVars As Integer Dim intNumCols As Integer Dim strVarName As String Dim strSyntax As String Dim intObjectType As Integer Dim i As Integer strParam = objSpssApp.ScriptParameter(0) 'Set object type to SPSS Pivot table intObjectType = 5 'Convert Script Parameter string to an array If strParam <> "" Then Call Get_PivotTable(objPivotTable, objItem, bolFoundOutputDoc, bolPivotSelected, intObjectType) If (bolFoundOutputDoc = False) Or (bolPivotSelected = False) Then 'Exit if viewer or pivot table not available or selected Exit Sub End If 'Defer screen update until we're done with the object objPivotTable.UpdateScreen = False intDelimiter = 124 Call Str_To_Array(strParam, strFormatArray, intUnitSize, intDelimiter) intDelimiter = 44 If UBound(strFormatArray) > 0 Then strParam = strFormatArray(0) Call Str_To_Array(strParam, strRowWidthArray, intUnitSize, intDelimiter) 'Send user specified row label widths Call Set_RowLabel_Width(strRowWidthArray) strParam = strFormatArray(1) Call Str_To_Array(strParam, strColWidthArray, intUnitSize, intDelimiter) Else strParam = strFormatArray(0) Call Str_To_Array(strParam, strColWidthArray, intUnitSize, intDelimiter) End If 'Send user specified column label widths Call Set_ColLabel_Width(strColWidthArray) End If If strParam = "" Then 'Set object type to SPSSNote intObjectType = 4 'Find NOTES that accompany selected Pivot Table Call Get_PivotTable(objPivotTable, objItem, bolFoundOutputDoc, bolPivotSelected, intObjectType) 'Defer screen update until we're done with the object objPivotTable.UpdateScreen = False 'Retrieve SYNTAX from NOTES object Call Get_Table_Syntax(objPivotTable, objItem, strSyntax) 'Location of Pivot Table selected by USER is passed from Get_PivotTable in intObjectType i = intObjectType 'Set delimiter of SYNTAX to vbCR intDelimiter = 13 Call Str_To_Array(strSyntax, strTableSyntaxArray, intUnitSize, intDelimiter) Call Create_Table_Format_Syntax(objPivotTable, objItem, strTableSyntaxArray, i) End If 'Perform all screen updates at once objPivotTable.UpdateScreen = True 'Deactivate Pivot Table objItem.Deactivate End Sub Sub Set_ColLabel_Width(strArrVar() As String) 'Declare SPSS object variables Dim objColumnLabels As ISpssLabels ' Column label arrays Dim objDataCells As ISpssDataCells 'Declare other variables used in this procedure Dim lngCol As Long ' Number of columns in COLUMN label array. Dim lngRow As Long ' Number of rows in COLUMN label array Dim lngR As Long ' Loop Counter Dim lngC As Long ' Loop Counter 'Get the column labels object Set objColumnLabels = objPivotTable.ColumnLabelArray Set objDataCells = objPivotTable.DataCellArray 'ColumnLabelArray is a 2-dimensional array. lngCol = objColumnLabels.NumColumns lngRow = objColumnLabels.NumRows 'Ensure number of columns widths specified does not exceed number of table columns If lngCol <= UBound(strArrVar) Then n = lngCol Else n = UBound(strArrVar) + 1 End If 'Select last row of column dimensions lngR = lngRow - 1 'For each column, set width if specified by user For lngC = 0 To n - 1 If Not IsNull(objColumnLabels.ValueAt(lngR,lngC)) Then If Len(strArrVar(lngC)) > 0 Then If Trim(strArrVar(lngC)) = "0" Then objColumnLabels.HideLabelsWithDataAt(lngR, lngC) Else objDataCells.ReSizeColumn (lngC, Val(strArrVar(lngC))) End If End If End If Next lngC End Sub Sub Set_RowLabel_Width(strArrVar() As String) 'Declare SPSS object variables Dim objRowLabels As ISpssLabels ' Row label arrays 'Declare other variables used in this procedure Dim lngCol As Long ' Number of columns in COLUMN label array. Dim lngRow As Long ' Number of rows in COLUMN label array Dim lngR As Long ' Loop Counter Dim lngC As Long ' Loop Counter 'Get the row labels object Set objRowLabels = objPivotTable.RowLabelArray 'RowLabelArray is a 2-dimensional array. Loop through the cells to ' find the label text that matches the target text (strText) lngCol = objRowLabels.NumColumns lngRow = objRowLabels.NumRows If lngCol <= UBound(strArrVar) Then n = lngCol Else n = UBound(strArrVar) + 1 End If 'Select top row of column dimensions for row labels lngR = 0 'For each column, set width if specified by user For lngC = 0 To n - 1 If Not IsNull(objRowLabels.ValueAt(lngR,lngC)) Then If Len(strArrVar(lngC)) > 0 Then objRowLabels.RowLabelWidthAt(lngR,lngC + 1) = CLng(strArrVar(lngC)) End If End If Next lngC End Sub Sub Str_To_Array(strVar As String, strArrVar() As String, intUnitSize As Long, intDelimiter As Integer) 'Function : This subroutine takes a user specified delimited string and ' : splits the elements into the returned array . ' : The number of elements returned is 'Inputs : strVar - delimited string 'Outputs : strArrVar - array returned of varnames ' : intArrSize - number of elements(variables) in array 'Origin : Adapted by AW Jan 1997 from MD project by JM Sept 1994 'Updates : Adapted by JB Aug 1998 to use a user specified Dim intStart As Integer Dim intRet_Loc As Integer Dim ii As Integer Dim strToken As String intStart = 1 intRet_Loc = 1 ii = 0 'Provide for specification given in millimeters, denoted by mm If (intDelimiter = 124) And (UCase$(Left(strVar,2)) = "MM") Then strVar = Mid(strVar, 3) intUnitSize = 72/25.4 ElseIf intDelimiter = 124 Then intUnitSize = 1 End If Debug.Print intDelimiter Do While intRet_Loc > 0 intRet_Loc = InStr(intStart, strVar, Chr(intDelimiter)) If (intRet_Loc > 0) Then strToken = Mid(strVar, intStart, intRet_Loc - intStart) intStart = intRet_Loc + 1 Else strToken = Mid(strVar, intStart, Len(strVar) + 1 - intStart) intStart = intRet_Loc + 1 End If ReDim Preserve strArrVar(ii) If Trim(strToken)<>"" And intDelimiter = 44 Then strArrVar(ii) = Str$(Val(Trim(strToken))* intUnitSize) ElseIf Trim(strToken)<>"" And intDelimiter = 13 Then strArrVar(ii) = Left(RTrim(strToken), Len(RTrim(strToken))) Else strArrVar(ii) = Trim(strToken) End If Debug.Print strArrVar(ii) & "*" ii = ii + 1 Loop End Sub Sub Get_PivotTable(objSelectedPivot As Object, objItem As ISpssItem, bolFoundOutput As Boolean, bolFoundPivot As Boolean, intType As Integer) 'Function : Find the first selected Pivot Table 'Assumptions : A Pivot Table is selected in the Output Doc (Navigator) 'Effects : Activates the selected Pivot Table 'Inputs : PivotTable object, Item object that contains selected PivotTable 'Return Values : Selected PivotTable, Item in the Viewer ' bolFoundOutput(True If an Output Doc exists) ' bolFoundPivot(True If found a selected PivotTable) Dim objDocuments As ISpssDocuments ' SPSS documents. Dim objOutputDoc As ISpssOutputDoc ' Output document Dim objItems As ISpssItems ' Output Navigator items Dim intItemCount As Integer Dim intItemType As Integer Dim bolSelected As Boolean ' True if an item is selected. Dim i As Integer ' We have not found an output navigator yet (Set flag) bolFoundOutput = False 'Get list of documents in SPSS. Set objDocuments = objSpssApp.Documents ' Get designated document only if there is at least one output document. If objDocuments.OutputDocCount > 0 Then 'Get the currently designated Viewer document. Set objOutputDoc = objSpssApp.GetDesignatedOutputDoc bolFoundOutput = True Else 'If no Viewer window exists. MsgBox(cNONAVMSG) Exit Sub End If 'Check if we found the designated document. If bolFoundOutput = True Then 'We have not found a pivot table.(Set flag) bolFoundPivot = False ' Get the outline tree and the number of items: Set objItems = objOutputDoc.Items intItemCount = objItems.Count If objSpssApp.ScriptParameter(0)<>"" Then ' Get the last pivot table in the Viewer if format paramters provided. For i = intItemCount - 1 To 0 Step -1 Set objItem = objItems.GetItem(i) intItemType = objItem.SPSSType bolSelected = objItem.Selected If intItemType = intType Then 'And bolSelected = True Then Set objSelectedPivot = objItem.Activate() 'Activate the pivot table. bolFoundPivot = True 'We did find a pivot table. Exit For 'Exit the loop. End If Next i ElseIf intType = 4 Then ' If SPSSNote For i = intItemCount - 1 To 0 Step -1 Set objItem = objItems.GetItem(i) bolSelected = objItem.Selected If bolSelected = True Then For j = i - 1 To 0 Step -1 Set objItem = objItems.GetItem(j) intItemType = objItem.SPSSType If objItem.SPSSType = intType Then Set objSelectedPivot = objItem.Activate() 'Store location of USER selected Pivot Table as intType intType = i Exit Sub End If Next j End If Next i Else ' Get current pivot table in Viewer. Call GetFirstSelectedPivot(objSelectedPivot, objItem, bolFoundOutput, bolFoundPivot) End If End If If bolFoundPivot = False Then 'If no pivot table has been selected. MsgBox(cNOPIVSELMSG) Exit Sub End If End Sub Sub Create_Table_Format_Syntax(objPivotTable As Object, objItem As ISpssItem, strArrVar() As String, intTest As Integer) 'Declare SPSS object variables Dim objRowLabels As ISpssLabels ' Row label arrays Dim objSyntaxDoc As ISpssSyntaxDoc Dim objDocuments As ISpssDocuments ' SPSS documents. Dim objOutputDoc As ISpssOutputDoc ' Output document Dim objItems As ISpssItems 'Declare other variables used in this procedure Dim strAppPath As String ' SPSS directory Dim intCol As Integer ' Number of columns in COLUMN label array. Dim intRow As Integer ' Number of rows in COLUMN label array Dim intR As Integer ' Loop Counter Dim intC As Integer ' Loop Counter Set objOutputDoc = objSpssApp.GetDesignatedOutputDoc Set objItems = objOutputDoc.Items Set objItem = objItems.GetItem(intTest) ' objItem.Selected = True Set objPivotTable = objItem.Activate() On Error GoTo Error_Handler 'Get row & column label objects Set objRowLabels = objPivotTable.RowLabelArray Set objColumnLabels = objPivotTable.ColumnLabelArray Set objSyntaxDoc = objSpssApp.GetDesignatedSyntaxDoc 'Determine SPSS directory strAppPath = objSpssApp.GetSPSSPath For i = 0 To UBound(strArrVar) strSyntaxCommands = strSyntaxCommands & strArrVar(i) & vbLf Next i strSyntaxCommands = strSyntaxCommands & "SCRIPT file = '" & strAppPath & "scripts\\" & cSCRIPTNAME & "' ('" intCol = objRowLabels.NumColumns intRow = objRowLabels.NumRows 'Select top row of column dimensions for row labels intR = 0 'For each column dimension, record width of row label 'Ignore Table Corner (Column 0) For intC = 1 To intCol - 2 'SPSS returns a zero value for width of row labels if unaltered since creation. 'To nullify any problems of zero value widths, we will screen such values. If objRowLabels.RowLabelWidthAt(intR,intC) <> 0 Then 'If Not IsNull(objRowLabels.ValueAt(intR,intC)) Then strSyntaxCommands = strSyntaxCommands & objRowLabels.RowLabelWidthAt(intR,intC) End If strSyntaxCommands = strSyntaxCommands & Chr(44) Next intC strSyntaxCommands = strSyntaxCommands & objRowLabels.RowLabelWidthAt(intR,intC) & Chr(124) intCol = objColumnLabels.NumColumns intRow = objColumnLabels.NumRows 'Select last row of column label dimensions intR = intRow - 1 'For each column, store column width For intC = 0 To intCol - 2 If Not IsNull(objColumnLabels.ValueAt(intR,intC)) Then strSyntaxCommands = strSyntaxCommands & objColumnLabels.ColumnLabelWidthAt(intR,intC) & Chr(44) End If Next intC strSyntaxCommands = strSyntaxCommands & objColumnLabels.ColumnLabelWidthAt(intR,intC) strSyntaxCommands = strSyntaxCommands + "')." & vbLf strSyntaxCommands = objSyntaxDoc.Text & strSyntaxCommands objSyntaxDoc.Text = strSyntaxCommands Exit Sub Error_Handler: 'Open syntax window if none Set objSyntaxDoc = objSpssApp.NewSyntaxDoc objSyntaxDoc.Visible = True Resume Next End Sub Sub Get_Table_Syntax (objPivot As Object, objItem As ISpssItem, strSyntax As String) Dim SYNTAX_COLUMN Dim cSYNTAX As String 'Declarations Dim intSelItemType As Integer Dim intVariableCount As Integer Dim intItem As Integer Dim lngRow As Long Dim strLabel As String Dim objSPSSInfo As ISpssInfo Dim objSPSSDataDoc As ISpssDataDoc Dim objRowLabels As ISpssLabels Dim objDataCells As ISpssDataCells Dim bolFoundOutputDoc As Boolean Dim bolItemSelected As Boolean SYNTAX_COLUMN = 2 'Column location of Syntax in NOTES cSYNTAX = "Syntax" 'These defaults indicate we haven't found the syntax and data file names strSyntax = "" ' Check if item is a Notes table intItemType = objItem.SPSSType If intItemType = SPSSNote Then ' Loop over the row labels from top to bottom Set objRowLabels = objPivot.RowLabelArray For lngRow = 0 To objRowLabels.NumRows - 1 'Make sure the label is present If Not IsNull(objRowLabels.ValueAt(lngRow, SYNTAX_COLUMN)) Then strLabel = objRowLabels.ValueAt(lngRow, SYNTAX_COLUMN) ' See if it is the syntax label If strLabel = cSYNTAX Then ' Capture the syntax string Set objDataCells = objPivot.DataCellArray If Not IsNull(objDataCells.ValueAt(lngRow, 0)) Then strSyntax = objDataCells.ValueAt(lngRow, 0) Exit For End If End If End If Next lngRow End If End Sub