Traffic Light with 3 Cut Off Points

 

Download as .sbs Shows as plain text

 

  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
'**********************************************************
'Select a Pivot Table and run this script. After entering
'high- and low-margin, the cells of the pivot table will
'be colored. All cells With values greater than high-margin
'will be colored In green. The values lower than low-margin
'will be red. And the values between the margins will be
'colored yellow.
'designed 1997 by Bernhard Witt - SPSS Germany
'**********************************************************

'Original Script has been modified by Raynald Levesque rlevesque@videotron.ca
'To skip the Dialog and always use .15 And .25 as the values
'If needed, use new values in lines between the ######### below.
'In addition, the color of cells whose values are above "ignore" are left un-colored.
'Date 2002/08/30.

Option Explicit
Const TextDialogBoxTitle = "Highlight"
Const TextDialogBoxHelp = "Help"
Const TextDialogBoxOben ="High margin:"
Const TextDialogBoxUnten ="Low margin:"
Const TextHelpText = "Select a Pivot Table and run this script. After entering high- and low-margin, the cells of the pivot table will be colored. All cells with values greater than high-margin will be colored in green. The values lower than low-margin will be red."+" And the values between the margins will be colored yellow." +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
	Dim oben As String
	Dim unten As String
	Dim ignore As String
'	erg=Dialog (dlg)
'####################################
	ignore="30"		'line added by Ray , hi ray why i try to change the ignor value to any value it does not response on the able color
	oben="10"
	unten="1"
'####################################	
'	If erg = -1 Then
		'Mach was
		Dim objItem As ISpssItem          		' A navigator item.
		Dim objPivotTable As PivotTable         ' Pivot table. 
		Dim bolFoundOutputDoc As Boolean
		Dim bolPivotSelected As Boolean


		'Call GetFirstSelectedPivot to get the selected pivot table 
		Call GetFirstSelectedPivot(objPivotTable, objItem, bolFoundOutputDoc, bolPivotSelected)

		If (bolFoundOutputDoc = False) Or (bolPivotSelected = False) Then
			'either there wasn't an output doc or a pivot table wasn't selected
			Exit Sub
		End If
	
		'global variable that keeps track of whether any cells are selected from searching
		s_bolCellsSelected = False	

		Dim objDataCells As ISpssDataCells
		Dim lngNumRows As Long
		Dim lngNumColumns As Long
		Set objDataCells = objPivotTable.DataCellArray
		' Loop through the cells and shades those cells with values less than 0.01:

		Dim objRowLabels As ISpssLabels         ' Row Label array.
		Set objRowLabels = objPivotTable.RowLabelArray
		Dim objColLabels As ISpssLabels         ' Col Label array.
		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 And objDataCells.ValueAt (I,J) < Val(ignore) Then 'line modified by Ray
								If objDataCells.ValueAt (I,J) <= Val(unten) Then
									objDataCells.BackgroundColorAt  (I,J) = red
									Debug.Print objDataCells.ValueAt (I,J) & " red"
								Else
									If objDataCells.ValueAt  (I,J) >= Val(oben)  Then
									objDataCells.BackgroundColorAt  (I,J) = green
									Debug.Print objDataCells.ValueAt (I,J) & " green"
									Else
										objDataCells.BackgroundColorAt  (I,J) = yellow
										Debug.Print objDataCells.ValueAt (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
		' Deactivate the pivot table and exit
		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	' Init
Case 2	' A Dialogfield was selected
	Select Case SteuerelementBez
	Case "OK"
	Case "Hilfe"
		Maskenfunktion=True
		MsgBox TextHelpText
	Case Else
		Maskenfunktion=False
	End Select
Case 3	' Textfield was changed

Case 4	' focus has changed

Case 5	' nothing else to do

Case Else

End Select

End Function
Related pages

...

Navigate from here