1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
'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