Table Widths

'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 <stvar> and
'			: splits the elements into the returned array <arrvar>.
'			: The number of elements returned is <arrsize>
'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