Traffic Light

 

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
'Begin Description
'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. 
'Requirements: The pivot table on which the script will be run should be selected.
'End Description

'**********************************************************
'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
'**********************************************************

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 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
	Dim oben As String
	Dim unten As String
'	erg=Dialog (dlg)
	oben=".25"
	unten=".15"
'	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 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
		' 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