«Светофор»: условное форматирование ячеек

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

'**********************************************************
'Разработано в 1997 году, автор: Bernhard Witt - SPSS Germany.
'Поставляется с SPSS Base
'**********************************************************

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

Option Explicit
Const TextDialogBoxTitle = "Подсветка ячеек на основе значений"
Const TextDialogBoxHelp = "Помощь"
Const TextDialogBoxOben ="Верхн. гран.:"
Const TextDialogBoxUnten ="Нижн. гран.:"
Const TextHelpText = "Выделите мобильную таблицу и запустите скрипт. После установки значений верхней и нижней границы, ячейки мобильной таблицы будут закрашены в зависимости от того, в какую часть отрезков, определённых границами, попадает их содержимое. Все ячейки со значениями выше верхней границы закрашиваются зелёным фоном. Ниже нижней - красным."+" Значения между двумя границами - жёлтым." +Chr$(13)+Chr$(13)+"Разработано в 1997 году, автор: Bernhard Witt - SPSS Germany"
'Const TextDialogBoxTitle = "Hai-Leiter"
'Const TextDialogBoxHelp = "Help"
'Const TextDialogBoxOben ="Obere Grenze:"
'Const TextDialogBoxUnten ="Untere Grenze:"
'Const TextHelpText = "Wдhlen Sie mit der Maus eine Pivot Tabelle aus und starten dieses Script. Nach Eingabe der oberen und unteren Grenze werden die Zellen der Pivot Tabelle farbig markiert. Alle Zellen, deren Wert grцЯer als die obere Grenze ist, werden grьn gefдrbt."+" Die Zellen, deren Wert kleiner als die untere Grenze ist, werden rot gekennzeichnet. Die Werte zwischen den Grenzen bekommen eine gelbe Frabe." +Chr$(13)+Chr$(13)+"designed 1997 by Bernhard Witt - SPSS Germany"
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) 'настройки желтого цвета


'Public s_bolCellsSelected As Boolean - удалено - А.Б.

Sub Main

	Begin Dialog UserDialog 30,30,450,77,TextDialogBoxTitle,.Maskenfunktion
		Text 10,18,100,21,TextDialogBoxOben
		Text 10,48,100,21,TextDialogBoxUnten
		TextBox 120,15,110,21,.oben
		TextBox 120,45,110,21,.unten
		OKButton 260,15,70,21,.ok
		PushButton 360,15,70,21,TextDialogBoxHelp,.Hilfe
		CancelButton 260,45,70,21,.Abbrechen
	End Dialog

	Dim dlg As UserDialog
	Dim erg As Boolean
	erg=Dialog (dlg)
	If erg = -1 Then
		'нажата кнопка OK
		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( dlg.unten) Then
								objDataCells.BackgroundColorAt  (I,J) = red
							Else
								If objDataCells.ValueAt  (I,J) >= Val( dlg.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 If
End Sub
 
'#########################################################################
Function Maskenfunktion(SteuerelementBez As String, Aktion As Integer , ZusatzWert As Integer )  As Boolean
'#########################################################################
Select Case Aktion
Case 1	' инициализация
Case 2	' выделено поле диалога
	Select Case SteuerelementBez
	Case "OK"
	Case "Hilfe" 'помощь
		Maskenfunktion=True
		MsgBox TextHelpText
	Case Else
		Maskenfunktion=False
	End Select
Case 3	' изменилось текстовое поле

Case 4	' изменился фокус

Case 5	' простой

Case Else

End Select

End Function