'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) 'Функция : берёт переданную пользователем строку с разделителями и ' : раскладывает её элементы по элементам массива . ' : Число элементов хранится в переменной - ? А.Б. 'Входящие : 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