VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmGlobalSelection
Caption = "SESIM Selection"
ClientHeight = 3945
ClientLeft = 4740
ClientTop = 3615
ClientWidth = 4845
LinkTopic = "Form1"
MDIChild = -1 'True
ScaleHeight = 3945
ScaleWidth = 4845
Begin VB.TextBox Text1
Height = 375
Left = 3000
TabIndex = 13
Text = "Text1"
Top = 720
Width = 495
Visible = 0 'False
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 3000
Top = 120
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton CmdHelp
Caption = "Help"
Height = 495
Left = 3000
TabIndex = 9
Top = 1680
Width = 495
End
Begin VB.CommandButton CmdDelete
Caption = "Delete Selection"
Enabled = 0 'False
Height = 495
Left = 2040
TabIndex = 7
Top = 1680
Width = 855
End
Begin VB.CommandButton CmdLoad
Caption = "Load from file"
Height = 495
Left = 1080
TabIndex = 6
Top = 1680
Width = 855
End
Begin VB.CommandButton CmdSaveFile
Caption = "Save to file"
Enabled = 0 'False
Height = 495
Left = 120
TabIndex = 5
Top = 1680
Width = 855
End
Begin MSFlexGridLib.MSFlexGrid GrdSel
Height = 1095
Left = 50
TabIndex = 8
Top = 2280
Width = 3615
_ExtentX = 6376
_ExtentY = 1931
_Version = 393216
SelectionMode = 1
AllowUserResizing= 1
End
Begin VB.Frame FrameSelection
Caption = "Multiple Selection"
Height = 1575
Left = 50
TabIndex = 0
Top = 0
Width = 2895
Begin VB.TextBox TxtVal
Height = 285
Left = 840
TabIndex = 3
Top = 1080
Width = 855
End
Begin VB.ComboBox CboOp
Height = 315
Left = 840
TabIndex = 2
Top = 720
Width = 855
End
Begin VB.ComboBox CboVar
Height = 315
Left = 840
TabIndex = 1
Top = 360
Width = 1455
End
Begin VB.CommandButton CmdSubmit
Caption = "Submit Selection"
Height = 615
Left = 1800
TabIndex = 4
Top = 840
Width = 975
End
Begin VB.Label Label5
Caption = "Value"
Height = 255
Left = 120
TabIndex = 12
Top = 1080
Width = 495
End
Begin VB.Label Label4
Caption = "Operator"
Height = 255
Left = 120
TabIndex = 11
Top = 720
Width = 735
End
Begin VB.Label Label3
Caption = "Variable"
Height = 255
Left = 120
TabIndex = 10
Top = 360
Width = 615
End
End
Begin VB.Label Label1
Height = 375
Left = 50
TabIndex = 14
Top = 3480
Width = 4575
End
End
Attribute VB_Name = "frmGlobalSelection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'************************************************************************
' Module frmGlobalSelection handles the global selection mechanism.
' Using the selection form the user can work with multiple selections
' of both individuals and/or households.
' When analyzing data using the SESIM viewers only selected items are
' included in the calculations.
' For more documentation see N:\FI_E4\Sesim\Dokumentation\
' global_selection_in_SESIM.doc.
'************************************************************************
Option Explicit
Option Base 1
'*** Sub CboOp_Validate erases the operator if not OK
Private Sub CboOp_Validate(Cancel As Boolean)
Dim i As Integer
Dim txt As String
Dim found As Boolean
txt = UCase(CboOp.text)
found = False
For i = 0 To CboOp.ListCount
If txt = CboOp.List(i) Then found = True
Next
If found = False Then
CboOp.text = ""
End If
End Sub
'*** Sub CboVar_Validate erases the variable name if not OK
Private Sub CboVar_Validate(Cancel As Boolean)
Dim i As Integer
Dim txt As String
Dim found As Boolean
Dim x As Variant
txt = UCase(CboVar.text)
found = False
For Each x In var_coll
If txt = UCase(x) Then found = True
Next x
If found = False Then
CboVar.text = ""
End If
End Sub
'***************************************************
' Delete selections from the selection list
'***************************************************
Private Sub CmdDelete_Click()
Dim templist() As SelItem, i As Integer, ndel As Integer
Dim count As Integer
ndel = maxi(GrdSel.RowSel, GrdSel.Row) - mini(GrdSel.RowSel, GrdSel.Row) + 1
If (nSelItems - ndel > 0) Then
ReDim templist(nSelItems - ndel)
count = 1
For i = 1 To nSelItems
If (i < mini(GrdSel.RowSel, GrdSel.Row) Or _
(i > maxi(GrdSel.RowSel, GrdSel.Row))) Then
templist(count) = SelLst(i)
count = count + 1
End If
Next i
SelLst = templist
nSelItems = nSelItems - ndel
Else
nSelItems = 0
ReDim SelLst(1)
CmdSaveFile.enabled = False
CmdDelete.enabled = False
End If
Call RedrawGrid
Call Recalc_Selections
'*** Tell all viewers to update themselves
Call controlcenter.update_viewers
End Sub
Private Sub CmdHelp_Click()
frmGlobalSelectionHelp.Show
End Sub
Private Sub CmdLoad_Click()
CommonDialog1.Filter = "Selections (*.Sel)|*.Sel"
CommonDialog1.InitDir = sesimpath & "\parameterdata"
CommonDialog1.ShowOpen
If CommonDialog1.filename <> "" Then
Dim filenr As Integer
filenr = FreeFile
Open CommonDialog1.filename For Binary As filenr
Get #filenr, , nSelItems
ReDim SelLst(nSelItems)
Get #filenr, , SelLst
Close filenr
If nSelItems > 0 Then CmdSaveFile.enabled = True
Call RedrawGrid
Call Recalc_Selections
'*** Tell all viewers to update themselves
Call controlcenter.update_viewers
End If
End Sub
Private Sub CmdSaveFile_Click()
CommonDialog1.Filter = "Selections (*.Sel)|*.Sel"
CommonDialog1.InitDir = sesimpath & "\parameterdata"
CommonDialog1.ShowSave
If CommonDialog1.filename <> "" Then
Dim filenr As Integer
filenr = FreeFile
Open CommonDialog1.filename For Binary As filenr
Put #filenr, , nSelItems
Put #filenr, , SelLst
Close filenr
End If
End Sub
Public Sub CmdSubmit_Click()
Dim newselection As SelItem
If frmGlobalSelection.TxtVal = "" Or frmGlobalSelection.CboOp = "" Or _
frmGlobalSelection.CboVar = "" Then Exit Sub
newselection.var = frmGlobalSelection.CboVar
newselection.op = frmGlobalSelection.CboOp
newselection.val = val(frmGlobalSelection.TxtVal)
ReDim Preserve SelLst(nSelItems + 1)
nSelItems = nSelItems + 1
SelLst(UBound(SelLst)) = newselection
'*** Redraw the grid
Call RedrawGrid
'*** Add the new selection criterion
Call Add_Selection(newselection.var, newselection.op, newselection.val)
'*** Tell all viewers to update themselves
Call controlcenter.update_viewers
' Erase textbox values
frmGlobalSelection.CboVar = ""
frmGlobalSelection.CboOp = ""
frmGlobalSelection.TxtVal = ""
CmdSaveFile.enabled = True
End Sub
Private Sub Form_Load()
Dim x As Variant
For Each x In var_coll
CboVar.AddItem x
Next x
CboOp.AddItem ""
CboOp.ItemData(CboOp.NewIndex) = 0
CboOp.AddItem "LT"
CboOp.ItemData(CboOp.NewIndex) = 1
CboOp.AddItem "LE"
CboOp.ItemData(CboOp.NewIndex) = 2
CboOp.AddItem "EQ"
CboOp.ItemData(CboOp.NewIndex) = 3
CboOp.AddItem "GE"
CboOp.ItemData(CboOp.NewIndex) = 4
CboOp.AddItem "GT"
CboOp.ItemData(CboOp.NewIndex) = 5
CboOp.AddItem "NE"
CboOp.ItemData(CboOp.NewIndex) = 6
nSelItems = 0
GrdSel.Cols = 4
GrdSel.Rows = 1
GrdSel.TextArray(0) = "Nr"
GrdSel.TextArray(1) = "Var"
GrdSel.TextArray(2) = "Op"
GrdSel.TextArray(3) = "Val"
Dim i As Integer
For i = 0 To GrdSel.Cols - 1
GrdSel.ColWidth(i) = 500
Next i
GrdSel.ColWidth(1) = GrdSel.Width - 2000
GrdSel.Refresh
frmGlobalSelection.Width = 3810
frmGlobalSelection.Height = 4600
' Only one selection viewer can exist
controlcenter.CmdGlobalSelection.enabled = False
End Sub
Private Sub Form_Resize()
GrdSel.Width = maxi(0, frmGlobalSelection.Width - 200)
GrdSel.Left = 50
GrdSel.Height = maxi(0, frmGlobalSelection.Height - 3000)
Dim i As Integer
For i = 0 To GrdSel.Cols - 1
GrdSel.ColWidth(i) = 500
Next i
GrdSel.ColWidth(1) = maxi(500, GrdSel.Width - 2000)
Label1.Top = maxi(2500, frmGlobalSelection.Height - 700)
If frmGlobalSelection.Height - 700 < 2500 Then
Label1.Visible = False
Else
Label1.Visible = True
End If
frmGlobalSelection.Refresh
End Sub
'*************************************************************
'*** When unloading all selections are removed from the
'*** selection vector and the viewers are updated.
'*************************************************************
Private Sub Form_Unload(Cancel As Integer)
Dim i As Long
SelIsOpen = False
' Delete the selection type
nSelItems = 0
Erase SelLst
' Remove all selections and update viewers
Call Recalc_Selections
'*** Tell all viewers to update themselves
Call controlcenter.update_viewers
' Allow new selection to be opened
controlcenter.CmdGlobalSelection.enabled = True
End Sub
Private Sub GrdSel_SelChange()
CmdDelete.enabled = True
End Sub
'***********************************************************
' Redraws the grid when changes to the selection vector has
' been made
'***********************************************************
Public Sub RedrawGrid()
' Erase all old selections from grid
GrdSel.Rows = 1
' Add new selections to grid
Dim i As Integer
Dim selstr As String
For i = 1 To nSelItems
selstr = CStr(i) & Chr(9) & (SelLst(i).var) & Chr(9) & _
CStr(SelLst(i).op) & Chr(9) & CStr(SelLst(i).val)
GrdSel.AddItem selstr
Next i
End Sub
'*************************************************************
' Sub Recalc_Selections recalculates the multiple selections
' that are listed in the selection form.
'*************************************************************
Private Sub Recalc_Selections()
Dim i As Long, is_temp() As Integer, hs_temp() As Integer
Dim tkn As String, j As Long, inr As Long, found As Integer
Dim sel As Byte
ReDim is_temp(m_icount) As Integer, hs_temp(m_hcount) As Integer
' Initially all individuals and households are selected
For i = 1 To m_icount
select_i(i) = 1
'*** DEBUG
i_selected(i) = 1
If i <= m_hcount Then
select_h(i) = 1
'*** DEBUG
h_selected(i) = 1
End If
Next i
' If selections exist then calculate...
If nSelItems > 0 Then
For i = 1 To nSelItems
tkn = Left(SelLst(i).var, 1)
' Individual level condition
If tkn = "i" Then
Call prepare_temp(SelLst(i).var)
' Check individuals
For j = 1 To m_icount
sel = Check_Cond(temp(j), SelLst(i).op, SelLst(i).val)
select_i(j) = select_i(j) * sel
'*** DEBUG
i_selected(j) = i_selected(j) * sel
Next j
' For each household - if some individual is selected then
' the household is selected
For j = 1 To m_hcount
inr = h_first_indnr(j)
found = 0
Do While inr <> 0 And found = 0
If select_i(indnr2index(inr)) = 1 Then found = 1
inr = i_next_indnr(indnr2index(inr))
Loop
select_h(j) = select_h(j) * found
'*** DEBUG
h_selected(j) = h_selected(j) * found
Next j
' Household level condition
Else
Call prepare_temp(SelLst(i).var)
' Check households
For j = 1 To m_hcount
sel = Check_Cond(temp(j), SelLst(i).op, SelLst(i).val)
select_h(j) = select_h(j) * sel
'*** DEBUG
h_selected(j) = h_selected(j) * sel
' All individuals in the household are selected (deselected) if the
' household is selected (deselected)
inr = h_first_indnr(j)
Do While inr <> 0
select_i(indnr2index(inr)) = select_i(indnr2index(inr)) * select_h(j)
'*** DEBUG
i_selected(indnr2index(inr)) = i_selected(indnr2index(inr)) * select_h(j)
inr = i_next_indnr(indnr2index(inr))
Loop
Next j
End If ' individual or household level condition
Next i ' next selection item
End If ' if selection items exist
' Calculate number of selected objects and write to label (if viewer open)
Dim isum As Long, hsum As Long
isum = L_SUMVEC(select_i(1), UBound(select_i)) * m_weight
hsum = L_SUMVEC(select_h(1), UBound(select_h)) * m_weight
frmGlobalSelection.Label1.Caption = _
"Selected: " & isum & " individuals, " & hsum & " households."
End Sub
Private Function Check_Cond(var, op, val) As Integer
Check_Cond = 0
Select Case UCase(op)
Case "LT"
If var < val Then Check_Cond = 1
Case "LE"
If var <= val Then Check_Cond = 1
Case "EQ"
If var = val Then Check_Cond = 1
Case "GE"
If var >= val Then Check_Cond = 1
Case "GT"
If var > val Then Check_Cond = 1
Case "NE"
If var <> val Then Check_Cond = 1
Case Else
End Select
End Function
'*******************************************************
'*** When loading windowstate from file or moving to a
'*** new year the SelLst type is updated and
'*** frmGlobalSelection is told to update itself by writing
'*** a random number into frmGlobalSelection.Text1
'*******************************************************
Private Sub Text1_Change()
Call RedrawGrid
Call Recalc_Selections
End Sub
'*************************************************************************************
'*** Sub Add_Selection recalculates the selection vectors due to one further
'*** condition given by arguments variable, operator and value.
'*** NOTE: this sub is more efficient than Sub Recalc_Selections because it does not
''** recalculate the whole SelLst structure.
'*************************************************************************************
Private Sub Add_Selection(ByVal variable As String, ByVal operator As String, _
ByVal value As Double)
Dim i As Long, j As Long, inr As Long
Dim sel As Byte
Dim found As Integer
Select Case (Left(variable, 2))
'*** Individual condition
Case "i_"
Call prepare_temp(variable)
'*** For each household check condition for all members. If at least one member
'*** is selected the household is selected.
For i = 1 To m_hcount
inr = h_first_indnr(i)
found = 0
Do While inr <> 0
sel = Check_Cond(temp(indnr2index(inr)), operator, value)
select_i(indnr2index(inr)) = select_i(indnr2index(inr)) * sel
If sel = 1 Then found = 1
inr = i_next_indnr(indnr2index(inr))
Loop
select_h(i) = select_h(i) * found
'*** DEBUG
h_selected(i) = h_selected(i) * found
Next
'*** Household condition
Case "h_"
Call prepare_temp(variable)
' Check households
For j = 1 To m_hcount
sel = Check_Cond(temp(j), operator, value)
select_h(j) = select_h(j) * sel
'*** DEBUG
h_selected(j) = h_selected(j) * sel
' All individuals in the household are selected (deselected) if the
' household is selected (deselected)
inr = h_first_indnr(j)
Do While inr <> 0
select_i(indnr2index(inr)) = select_i(indnr2index(inr)) * select_h(j)
'*** DEBUG
i_selected(indnr2index(inr)) = i_selected(indnr2index(inr)) * select_h(j)
inr = i_next_indnr(indnr2index(inr))
Loop
Next j
Case Else
End Select
'*** Calculate number of selected objects and write to label (if viewer open)
Dim isum As Long, hsum As Long
isum = L_SUMVEC(select_i(1), UBound(select_i)) * m_weight
hsum = L_SUMVEC(select_h(1), UBound(select_h)) * m_weight
frmGlobalSelection.Label1.Caption = _
"Selected: " & isum & " individuals, " & hsum & " households."
End Sub