«Светофор» с фиксированными границами

 

Загрузить как .sbs Показать простым текстом

 

 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
'Begin Description
'После установки значений верхней и нижней границы, ячейки мобильной таблицы будут
'закрашены в зависимости от того, в какую часть отрезков, определённых границами,
'попадает их содержимое. Все ячейки со значениями выше верхней границы закрашиваются
'зелёным фоном. Ниже нижней - красным. Значения между двумя границами - жёлтым.
'Условия: перед запуском скрипта обрабатываемая таблица должна быть выделена пользователем
'End Description

'**********************************************************
'Создан в 1997 году, автор: Bernhard Witt - SPSS Germany
'**********************************************************

'Исходный скрипт изменён Рейналем Левеком (Raynald Levesque rlevesque@videotron.ca).
'Скрипт не использует диалоговое окно, значения границ .15 и .25 указаны в коде скрипта.
'При необходимости пользователь может установить другие значения (между строками с метками ######### ниже).

'Перевод: А. Балабанов, 14.01.2009.
'Проверено: SPSS 15.0.0.
'Размещение: http://www.spsstools.ru/Script/PivotTables/TrafficLightFixed15and25.txt (.sbs).

Option Explicit
Const TextTotalStr ="Total"
Const TextTotalStr2 ="Gesamt"
Const red = RGB(178,34,34)'настройки красного цвета
Const green = RGB(60, 179, 113)'настройки зеленого цвета
Const white = RGB(255,255,255)'настройки белого цвета
Const yellow = RGB(255,255,128)'настройки желтого цвета



'### код для диалоговых окон удалён - А.Б.

Sub Main
Dim oben As String, unten As String
'####################################
	oben=".25"
	unten=".15"
'####################################	
		Dim objItem As ISpssItem          		' объект окна результатов
		Dim objPivotTable As PivotTable         ' объект-мобильная таблица.
		Dim bolFoundOutputDoc As Boolean
		Dim bolPivotSelected As Boolean


		'Вызов процедуры GetFirstSelectedPivot для установки ссылки на первую выделенную мобильную таблицу
		Call GetFirstSelectedPivot(objPivotTable, objItem, bolFoundOutputDoc, bolPivotSelected)

		If (bolFoundOutputDoc = False) Or (bolPivotSelected = False) Then
			'либо нет открытых окон результатов, либо таблица не выделена
			Exit Sub
		End If
	
		Dim objDataCells As ISpssDataCells
		Dim lngNumRows As Long
		Dim lngNumColumns As Long
		Set objDataCells = objPivotTable.DataCellArray
		' Осуществляем цикл по ячейкам и закрашиваем в соответствии с заданными границами

		Dim objRowLabels As ISpssLabels         ' массив меток строк
		Set objRowLabels = objPivotTable.RowLabelArray
		Dim objColLabels As ISpssLabels         ' массив меток столбцов
		Set objColLabels = objPivotTable.ColumnLabelArray
		lngNumRows = objDataCells.NumRows
		lngNumColumns = objDataCells.NumColumns
		Dim I As Integer, J As Integer
		objItem.Deactivate  
		For I = 0 To lngNumRows -1
			Dim dummy As Integer
			If InStr (objRowLabels.ValueAt(I,objRowLabels.NumColumns-1), TextTotalStr)= 0 And InStr (objRowLabels.ValueAt(I,objRowLabels.NumColumns-1), TextTotalStr2)= 0 Then
				For J = 0 To lngNumColumns -1
					If InStr (objColLabels.ValueAt(objColLabels.NumRows-1,J), TextTotalStr)= 0 And InStr (objColLabels.ValueAt(objColLabels.NumRows-1,J), TextTotalStr2)= 0 Then
						If Len(objDataCells.ValueAt  (I,J)) > 0 Then
							If objDataCells.ValueAt (I,J) <= Val(unten) Then
								objDataCells.BackgroundColorAt  (I,J) = red
							Else
								If objDataCells.ValueAt  (I,J) >= Val(oben)  Then
								objDataCells.BackgroundColorAt  (I,J) = green
								Else
									objDataCells.BackgroundColorAt  (I,J) = yellow
								End If
							End If
						Else
							objDataCells.BackgroundColorAt  (I,J) = white
						End If							
					End If
				Next
			Else
'				objDataCells.BackgroundColorAt  (I,J) = white 'при желании в прочих случаях можем красить белым цветом - А.Б.
			End If
		Next
		' деактивация мобильной таблицы и выход
		objItem.Activate  
		objItem.Deactivate  

End Sub
Related pages

...

Navigate from here