Управление шириной столбцов «через синтаксис»

'Begin Description
'Данный скрипт позволяет пользователю через синтаксис задать индивидуальную ширину для столбцов
'данных и меток строк в таблицах, создаваемых процедурами SPSS.
'End Description
'
'ТРЕБОВАНИЯ:
'		SPSS Base, верия 8.0 для Windows или выше.
'
'НАЗНАЧЕНИЕ:
'		Скрипт позволяет пользователю через синтаксис задать индивидуальную ширину для столбцов
'       данных и меток строк в мобильных таблицах, создаваемых процедурами SPSS.
'		Ширину можно задавать в пунктах или миллиметрах. Скрипт также позволяет создавать
'		корректный синтаксис для своего вызова на основе таблицы, в которой вы вручную
'		поправили ширину столбцов, так что вам не нужно переписывать размеры.
'
'ВХОДНЫЕ ПАРАМАТРЫ:
'		Скрипт требует указания ширины столбцов данных (а при необходимости - и ширины
'		столбцов в метками строк) при вызове его из окна редактора синтаксиса, причём
'		значения ширины столбцов разделяются запятыми. Значения ширины столбцов с метками
'		строк отделяются от прочих значений символом |. См. варианты использования A и Б.
''		Скрипт может быть использован и для "снятия мерки" с таблицы, в которой пользователь
'		вручную задал размеры столбцов, для последующего использования в синтаксисе. См. вариант использования В.
'		
'ИСПОЛЬЗОВАНИЕ:
'		Вызов из синтаксиса:
'		SCRIPT file = 'filename' ('{ед.}{r1,r2,...,rn|}c1,c2,...,cn')
'
'		здесь   ед.		mm = миллиметры [* по умолчанию - пункты *]
'				rn		ширина столбца n с метками строк [необязательные параметры]
'				cn		ширина столбца данных n
'
'		ВАРИАНТ ИСПОЛЬЗОВАНИЯ А:
'
'		SCRIPT file="c:\\...\\spss\\scripts\\Table Widths - with Syntax.sbs" ("95,,95,,50").
'		
'		Устанавливает ширину первого и третьего столбца в 95 пунктов, пятого столбца - в 50 пунктов.
'		Ширина второго, четвёртого и всех последующих столбцов не изменяется.
'		Указание ширины для несуществующих фактически в таблице столбцов игнорируются.
'
'		ВАРИАНТ ИСПОЛЬЗОВАНИЯ Б:
'
'		SCRIPT file="c:\\...\\spss\\scripts\\Table Widths - with Syntax.sbs" ("mm 80|,20,,35").
'
'		Устанавливает ширину первого столбца с метками строк в 80 мм.
'		Ширина второго столбца с данными делается равной 20 мм, а четвёртого - 35 мм.
'		Первый, третий и все последующие столбцы данных своей ширины не меняют.
'
'		ВАРИАНТ ИСПОЛЬЗОВАНИЯ В:
'
'		Если вы запустите этот скрипт через меню Utilities>Run Script, он создаст синтаксис,
'		в котором "запомнит" размеры столбцов, выделенной таблицы, которую вы можете предварительно
'		подправить под нужное вам форматирование. Этот синтаксис вставится в назначенное окно синтаксиса.
'
'		Скрипт также попутно определит синтаксис, который был использован для создания самой таблицы.
'		Обе команды будут вставлены в окно синтаксиса.

'Примеч. перев.: если команда производит несколько таблиц, и вы вручную изменили ширину столбцов какой-либо
'непоследней таблицы и запомнили эти размеры через запуск скрипта, сгенерированный синтаксис будет таков, что
'запомненные размеры скрипт будет пытаться воспроизводить на последней таблице из выдачи - это следует учитывать
'при написании программ обработки.
'
'ПРИМЕЧАНИЯ:
'		Единицы измерения по умолчанию - пункты. При необходимости можно указать миллиметры (mm).
'
'		Скрипт выделяет и изменяет последнюю мобильную таблицу, которая была создана перед вызовом скрипта.
'
'		Указание ширины столбца равной 0 приведёт к скрытию этого столбца.
'
'       Скрипт следует сохранить с именем "Table Widths - with syntax.sbs". ЭТО ВАЖНО.
'
'ВЕРСИЯ:
'		Версия			: 1.1a
'		Обновлено		: 26 ноября 2001 г.
'
'АВТОР:
'		Имя				: Jason Burke, SPSS Australasia Pty Ltd.
'		Телефон			: +61 (0)2 9954 5660 ext 242
'		E-Mail			: jburke AT spss DOT com
'		Авторские права : Copyright @ 1999 by Jason Burke.
'
'*****************************************************************************


'Константы уровня скрипта
Const cSCRIPTNAME As String = "Table Widths - with syntax.sbs"

Const cNONAVMSG As String = "Не найдено документов редактора результатов (output)."
Const cNOPIVSELMSG As String = "Выделите мобильную таблицу перед запуском скрипта."

Public objPivotTable As PivotTable


Sub Main

'Строка со значениями ширины столбцов передаётся в качестве параметра из синтаксиса.
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)
	'Устанавливаем константу для определения типа объекта "мобильная таблица" (SPSS Pivot table)
	intObjectType = 5 

 	'Если передан параметр, надо будет разложить переданное по элементам массива
 	If strParam <> "" Then
		
	Call Get_PivotTable(objPivotTable, objItem, bolFoundOutputDoc, bolPivotSelected, intObjectType)

	If (bolFoundOutputDoc = False) Or (bolPivotSelected = False) Then
		'выход, если окно результатов не существует или мобильная таблица не выделена
		Exit Sub
	End If

	'Откладываем перерисовку экрана до окончания обработки объекта
	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)
			'устанавливаем ширину столбцов, относящихся к меткам строк
			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

		'устанавливаем ширину столбцов с данными
		Call Set_ColLabel_Width(strColWidthArray)

	End If

	If strParam = "" Then 

		'Устанавливаем константу для определения типа объекта "примечания" (SPSSNote) - дополнительная (и обычно скрытая)
		'таблица со служебной информацией, которая создаётся после каждого вызова статистической процедуры.
 		intObjectType = 4
 		
 		'Ищем объект-таблицу "примечания", соответствующую выделенной мобильной таблице
		Call Get_PivotTable(objPivotTable, objItem, bolFoundOutputDoc, bolPivotSelected, intObjectType)

		'Откладываем перерисовку экрана до окончания обработки объекта
		objPivotTable.UpdateScreen = False

		'"Вытягиваем" синтаксис из таблицы NOTES ("примечания")
		Call Get_Table_Syntax(objPivotTable, objItem, strSyntax)
			
		'запоминаем расположение таблицы, выделенной пользователем (его нам вернула в переменной intObjectType функция Get_PivotTable)
 		i = intObjectType
 		
 		'устанавливаем разделитель для строки с синтаксисом vbCR (возврат каретки)
 		intDelimiter = 13
	 		
 		Call Str_To_Array(strSyntax, strTableSyntaxArray, intUnitSize, intDelimiter)
 		Call Create_Table_Format_Syntax(objPivotTable, objItem, strTableSyntaxArray, i)

	End If


	'разрешим обновить экран
	objPivotTable.UpdateScreen = True

	'деактивация мобильной таблицы
	objItem.Deactivate  

End Sub


Sub Set_ColLabel_Width(strArrVar() As String)
	
'Объявление объектных переменных SPSS
Dim objColumnLabels As ISpssLabels      ' массив меток столбцов
Dim objDataCells As ISpssDataCells

'Объявление прочих переменных, используемых в процедуре
Dim lngCol As Long                   ' число столбцов в массиве меток СТОЛБЦОВ
Dim lngRow As Long                   ' число строк в массиве меток СТОЛБЦОВ
Dim lngR As Long                     ' счетчик цикла
Dim lngC As Long                     ' счетчик цикла

			
'ссылка на массив с метками столбцов
Set objColumnLabels = objPivotTable.ColumnLabelArray
Set objDataCells = objPivotTable.DataCellArray
	
	'ColumnLabelArray - двумерный массив.
	lngCol = objColumnLabels.NumColumns
	lngRow = objColumnLabels.NumRows

	'Обеспечим, чтобы количество устанавливаемых значений ширины столбца не превышало количество столбцов
	If lngCol <= UBound(strArrVar) Then
		n = lngCol
	Else
		n = UBound(strArrVar) + 1
	End If

	'Становимся на последнюю строку в массиве меток столбцов
	lngR = lngRow - 1
		'для каждого столбца устанавливаем заданную пользователем ширину
		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) 

'Объявление объектных переменных SPSS
Dim objRowLabels As ISpssLabels			' массив меток строк

'Объявление прочих переменных, используемых в процедуре
Dim lngCol As Long                   ' число столбцов в массиве меток СТРОК
Dim lngRow As Long                   ' число строк в массиве меток СТРОК
Dim lngR As Long                     ' счетчик цикла
Dim lngC As Long                     ' счетчик цикла

	'ссылка на объект меток строк
	Set objRowLabels = objPivotTable.RowLabelArray
	
	'RowLabelArray - двумерный массив.
	lngCol = objRowLabels.NumColumns
	lngRow = objRowLabels.NumRows
	
	If lngCol <= UBound(strArrVar) Then
		n = lngCol
	Else
		n = UBound(strArrVar) + 1
	End If

	'становимся на верхнюю строку размерности с метками строк
	lngR = 0
		'для каждого столбца, относящегося к меткам строк (их может быть несколько), устанавливаем желаемую ширину
		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)
'Функция	: берёт переданную пользователем строку с разделителями <stvar> и
'			: раскладывает её элементы по элементам массива <arrvar>.
'			: Число элементов хранится в переменной <arrsize> - ? А.Б.
'Входящие	: strVar 		- строка с разделителями
'Выходящие	: strArrVar 	- возвращаемый массив
'			: intArrSize	- число элементов (переменных) в массиве - не используется? - А.Б.
'Исх. версия: автор AW, январь 1997, адаптация по проекту MD (авторе - JM), сент. 1994.
'Обновления	: автор JB, август 1998, адаптация

Dim intStart As Integer
Dim intRet_Loc As Integer
Dim ii As Integer
Dim strToken As String
   
intStart = 1
intRet_Loc = 1
ii = 0


'особо обрабатываем строку, если единицы в ней указаны в миллиметрах
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)
'Функция	: поиск первой выделенной таблицы (не только: + доп. функциональность для задач скрипта - примеч. перев.)
'Условия	: в окне результатов выделена мобильная таблица
'Действия	: активирует выделенную мобильную таблицу
'Входные	: объект "мобильная таблица" и "родительский" объект, содержащий выделенную таблицу, тип искомой таблицы
'Выходные	: выделенная таблица и родительский объект
'			  bolFoundOutput("истина", если есть окно результатов)
'			  bolFoundPivot("истина", если найдена выделенная мобильная таблица)

	Dim objDocuments As ISpssDocuments     	' коллекция документов SPSS
	Dim objOutputDoc As ISpssOutputDoc      ' документ Output (окно результатов)
	Dim objItems As ISpssItems       		' коллекция объектов в окне результатов
	Dim intItemCount As Integer
	Dim intItemType As Integer
	Dim bolSelected As Boolean             	' "Истина", если объект выделен
	Dim i As Integer
	
	' устанавливаем признак того, что окно результатов ещё не обнаружено
	bolFoundOutput = False
	
	'получаем перечень (коллекцию) документов SPSS.
	Set objDocuments = objSpssApp.Documents
	
	' ссылка на назначенное окно результатов только есть хотя бы одно окно результатов
	If objDocuments.OutputDocCount > 0 Then
	   'ссылка на назначенное окно результатов
	   Set objOutputDoc = objSpssApp.GetDesignatedOutputDoc
	   bolFoundOutput = True
	Else
		'если не обнаружено окна результатов
		MsgBox(cNONAVMSG)
		Exit Sub
	End If
	
	'проверка, что назначенное окно результатов обнаружено
	If bolFoundOutput = True Then
		'признак, что мобильная таблица ещё не найдена
		bolFoundPivot = False
	
		' ставим ссылку на дерево объектов и подсчитываем их количество
		Set objItems = objOutputDoc.Items
		intItemCount = objItems.Count
		If objSpssApp.ScriptParameter(0)<>"" Then
			' ставим ссылку на последнюю мобильную таблицу в окне результатов, если передан параметр с шириной столбцов
			For i = intItemCount - 1 To 0 Step -1
				Set objItem = objItems.GetItem(i)
				intItemType = objItem.SPSSType
				bolSelected = objItem.Selected
				If intItemType = intType Then					'
					Set objSelectedPivot = objItem.Activate()  	'активируем мобильную таблицу
					bolFoundPivot  = True	                  	'признак того, что таблица найдена
					Exit For                                  	'выход из цикла
		        End If
			Next i
		ElseIf intType = 4 Then ' если найденный объект - 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()
							'запоминаем индекс найденной таблицы в переменной intType
							intType = i							
							Exit Sub
						End If
					Next j
				End If
		   Next i
		Else
			' ставим ссылку на первую выделенную таблицу
			Call GetFirstSelectedPivot(objSelectedPivot, objItem, bolFoundOutput, bolFoundPivot)
		End If
	End If
	
	If bolFoundPivot = False Then
		'Если не выделено (не найдено) нужной таблицы
		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)

'Объявление объектных переменных SPSS
Dim objRowLabels As ISpssLabels			' массив меток строк
Dim objSyntaxDoc As ISpssSyntaxDoc
Dim objDocuments As ISpssDocuments     	' коллекция документов SPSS.
Dim objOutputDoc As ISpssOutputDoc      ' документ результатов (Output)
Dim objItems As ISpssItems

'Объявление прочих переменных, которые используются в процедуре
Dim strAppPath As String				' путь, куда установлен SPSS
Dim intCol As Integer                   ' число столбцов в массиве меток СТОЛБЦОВ
Dim intRow As Integer                   ' число строк в массиве меток СТОЛБЦОВ
Dim intR As Integer                     ' счетчик цикла
Dim intC As Integer                     ' счетчик цикла


	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
	
	'установка ссылок на массивы меток строк и столбцов
	Set objRowLabels = objPivotTable.RowLabelArray
	Set objColumnLabels = objPivotTable.ColumnLabelArray
	Set objSyntaxDoc = objSpssApp.GetDesignatedSyntaxDoc

	'Определение папки, куда установлен SPSS
	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
	
	'встаём на верхнюю строчку размерности с метками строк
	intR = 0

	'для каждого столбца, формирующего метки строк, записываем его ширину
	'игнорируем верхний левый угол таблицы (столбец 0)
	For intC = 1 To intCol - 2
		'SPSS возвращает нулевое значение для ширины столбца с метками строк, если столбец не изменял своей ширины после создания таблицы.
		'Чтобы избежать проблем, связанных с этим, мы проверяем возвращаемые значения.
		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

	'Встанем на последнюю строку размерности меток столбцов
	intR = intRow - 1

	'сохраняем ширину каждого столбца
	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:
'откроем окно синтаксиса, если его нет

	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 

	'Объявляем переменные
	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 'столбец, в котором располагается синтаксис в таблице примечаний
	cSYNTAX = "Syntax"
	
	'исходное значение - признак, что синтаксис ещё не обнаружен
	strSyntax = ""

	' проверка, что переданный объект имеет нужный тип - таблицы примечаний (Notes)
	intItemType = objItem.SPSSType
	If intItemType = SPSSNote Then
	
		' цикл по меткам строк сверху вниз
		Set objRowLabels = objPivot.RowLabelArray
		For lngRow = 0 To objRowLabels.NumRows - 1

			'проверка, что метка присутствует (ячейка не пуста)
			If Not IsNull(objRowLabels.ValueAt(lngRow, SYNTAX_COLUMN)) Then
				strLabel = objRowLabels.ValueAt(lngRow, SYNTAX_COLUMN)

				' проверка, не это ли строка синтаксиса ("Syntax")
				If strLabel = cSYNTAX Then

					' захват синтаксиса
					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