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 | 'Begin Description
'Обеспечивает курсивное начертание процентным показателям во всех мобильных таблицах. Другие варианты начертания
'можно задать с помощью 4 констант, определённых ниже.
'Скрипт также можно использовать для замены фона соответствующих ячеек
'Размещено в SPSSX-L, автор: Raynald Levesque, 13.11.2004.
'End Description
'Размещение: http://www.spsstools.ru/Scripts/PivotTables/ItalizePercentagesInPivotTables.txt (.sbs).
'Перевод: А. Балабанов, 02.01.2009. ###внесённые изменения связаны с неустойчивой работой скрипта в таблицах с пустыми ячейками - А.Б.
'Проверено: SPSS 15.0.1.1.
Option Explicit
'Одна из следующих констант может быть использована вами в строке "Call ChangeTextStyle()" ниже
Const cNORMAL=0
Const cITALIC=1
Const cBOLD=2
Const cBOLDITALIC=3
Dim bolUpdated As Boolean '###добавлено - А.Б.
Option Explicit
Sub Main
Dim objPivot As PivotTable
Dim objItem As ISpssItem
Do While GetNextPivot(objPivot, objItem)
'запрет обновления экрана до завершения работы
objPivot.UpdateScreen = False
Call ChangeTextStyle(objPivot, "%", cITALIC, vbWhite)
'Call ChangeTextStyle(objPivot, "%", cNORMAL, vbYellow) - в таком вариенте будет замена фона на жёлтый - А.Б.
objPivot.UpdateScreen = True
If bolUpdated Then '###добавлено (не делаем автоподгонку таблиц, которые не изменяли) - А.Б.
objPivot.Autofit
objItem.Deactivate
objItem.ActivateTable 'гарантируем полное обновление таблицы
End If '###добавлено - А.Б.
objItem.Deactivate
Loop
End Sub
Sub ChangeTextStyle(objPivot As PivotTable, strNeedle As String , intTextStyle As Integer, lngBackColor As Long)
Dim lngRow As Long, lngCol As Long
Dim objDataCells As ISpssDataCells
Dim strFormat As String
bolUpdated=False
Set objDataCells = objPivot.DataCellArray
With objDataCells
For lngRow = 0 To .NumRows - 1
For lngCol = 0 To .NumColumns - 1
If Not IsNull (.ValueAt (lngRow, lngCol)) Then '### изменено (сначала проверим, не пуста ли ячейка, а затем - получим её формат) - А.Б.
strFormat = .NumericFormatAt(lngRow,lngCol) '### изменено - А.Б.
If InStr(strFormat,strNeedle)>0 Then '### изменено - А.Б.
.TextStyleAt(lngRow,lngCol)= intTextStyle
.BackgroundColorAt(lngRow,lngCol)= lngBackColor
bolUpdated=True '###добавлено - А.Б.
End If '### изменено - А.Б.
End If
Next
Next
End With
'objPivot.Autofit ###удалено - А.Б.
End Sub
Function GetNextPivot(objPivot As PivotTable, objItem As ISpssItem) As Boolean
'Назначение: нахождение следующей мобильной таблицы
'Условия: в окне Навигатора находятся таблицы; окно не меняет своего содержимого между вызовами функции
'Действия: каждый раз при вызове функции она выделяет и активирует следующую мобильную таблицу
'Входные значения: объект PivotTable (мобильная таблица), объект Item - контейнер выделенной мобильной таблицы
'Выходные значения: активированная мобильная таблица, указание на выделенный элемент, функция возвращает значение "истина", если мобильная таблица найдена
'Программный код этой процедуры составлен SPSS
'Заметьте, что функция содержит статические переменные, что позволяет осуществлять контроль перебора таблиц в окне результатов
'непосредственно в самой функции (информация о текущем положении курсора не теряется между вызовами функции).
'Кроме того, функция не только возвращает в процедуру Main своё "основное" значение (Истина/Ложь), но и переопределяет значения
'переменных objPivot и objItem, которые далее используются процедурой Main.
'При первом вызове статические переменные ещё не определены; функция контролирует это и определяет их, если требуется - примеч. перев.
Static objDocuments As ISpssDocuments ' коллекция документов SPSS
Static objOutputDoc As ISpssOutputDoc ' документ выдачи (результатов, Output)
Static objItems As ISpssItems ' коллекция объектов окна выдачи (Output Navigator)
Static intItem As Integer ' индекс объекта окна Output Navigator
Static intItemCount As Integer ' общее число объектов в окне выдачи
Dim intItemType As Integer
Dim bolSelected As Boolean ' истина, если объект выделен
Dim bolReset As Boolean
Dim i As Integer
' инициализация выходных значений
GetNextPivot = False
Set objPivot = Nothing
Set objItem = Nothing
' если это первый вызов, установим флаг, сигнализирующий о необходимости инициализации ряда переменных
If (objDocuments Is Nothing) Or (objOutputDoc Is Nothing) Or (objItems Is Nothing) Then
bolReset = True
End If
If bolReset Then
'получим перечень документов в SPSS.
Set objDocuments = objSpssApp.Documents
End If ' закончена обработка перечня документов
If bolReset Then
' Получаем ссылку на документ результатов только если есть хотя бы один такой документ
If objDocuments.OutputDocCount > 0 Then
'Ссылка на назначенное окно результатов
Set objOutputDoc = objSpssApp.GetDesignatedOutputDoc
Else
'если нет окон результатов
MsgBox( "Не найдено окна результатов!" )
Exit Function
End If
End If ' закончили с документом результатов
' Ссылка на дерево элементов и подсчёт их числа
If bolReset Then
Set objItems = objOutputDoc.Items
intItemCount = objItems.Count
End If
' чтобы не создать проблем, если что-то не так, контролируем, что нужные переменные определены
If (objDocuments Is Nothing) Or (objOutputDoc Is Nothing) Or (objItems Is Nothing) Then
Debug.Print "Переменная objDocuments не определена (Nothing): " & (objDocuments Is Nothing)
Debug.Print "Переменная objOutputDoc не определена (Nothing): " & (objOutputDoc Is Nothing)
Debug.Print "Переменная objItems не определена (Nothing): " & (objItems Is Nothing)
MsgBox "Произошли ошибки при работе с документом результатов.", vbExclamation, "Функция GetNextPivot"
Exit Function
End If
' контроль того, что документ не изменился между вызовами (на основе подсчёта числа элементов)
If intItemCount <> objItems.Count Then
MsgBox "Содержимое окна результатов неожиданно изменилось во время выполнения скрипта.", vbExclamation, "Функция GetNextPivot"
Exit Function
End If
If bolReset Then
intItem = 0
End If
' Активация следующей мобильной таблицы
For i = intItem To intItemCount - 1
Set objItem = objItems.GetItem(i)
intItemType = objItem.SPSSType
If intItemType = SPSSPivot Then
intItem = i + 1 ' запоминаем состояние счётчика цикла
Set objPivot = objItem.ActivateTable() ' активация мобильной таблицы
GetNextPivot = True ' таблица найдена
Exit For ' выход из цикла
End If
Next i
If GetNextPivot = False And intItem = 0 Then
'не было обнаружено мобильных таблиц
MsgBox( "В окне результатов не обнаружено мобильных таблиц." )
Exit Function
End If
End Function
|