'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