VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Begin VB.Form monitor_stat
Caption = "Statistics"
ClientHeight = 3900
ClientLeft = 60
ClientTop = 345
ClientWidth = 7200
LinkTopic = "Form1"
MDIChild = -1 'True
ScaleHeight = 3900
ScaleWidth = 7200
Begin VB.TextBox txtVal2
Height = 285
Left = 1680
TabIndex = 5
Top = 840
Width = 855
End
Begin VB.CommandButton cmdCompute
Caption = "Compute"
Height = 375
Left = 3240
TabIndex = 4
Top = 720
Width = 1215
End
Begin VB.ComboBox Combo2
Height = 315
Left = 120
TabIndex = 3
Text = "Combo2"
Top = 840
Width = 1455
End
Begin RichTextLib.RichTextBox resultbox
Height = 1695
Left = 120
TabIndex = 2
Top = 1320
Width = 3615
_ExtentX = 6376
_ExtentY = 2990
_Version = 393217
Enabled = -1 'True
TextRTF = $"monitor_stat.frx":0000
End
Begin VB.ComboBox Combo1
Height = 315
ItemData = "monitor_stat.frx":00C9
Left = 120
List = "monitor_stat.frx":00CB
TabIndex = 1
Text = "Combo1"
Top = 240
Width = 1455
End
Begin VB.TextBox Text1
Height = 375
Left = 3240
TabIndex = 0
Text = "Text1"
Top = 120
Width = 1095
End
End
Attribute VB_Name = "monitor_stat"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim variable1() As Variant
Dim variable2() As Variant
Dim combo1txt As String
Dim combo2txt As String
'***********************************************************************************
Private Sub Form_Load()
' Fetch variable names from collection
Dim cv
Combo1.Clear
Combo2.Clear
For Each cv In varcom_coll
Combo1.AddItem cv
Combo2.AddItem cv
Next
End Sub
'***********************************************************************************
Public Sub Combo1_Click()
Call prepare1
End Sub
'***********************************************************************************
Public Sub Combo2_Click()
Call prepare2
End Sub
'***********************************************************************************
Private Sub prepare1()
Dim i As Long
Dim n As Long
' Get variable part from combo box
combo1txt = getword(Combo1.text, 1, " ")
If combo1txt = "" Then Exit Sub
' Move data from vector with name combo1txt to vector "temp"
Call prepare_temp(combo1txt)
If Mid$(combo1txt, 1, 1) = "i" Then
n = m_icount
Else
n = m_hcount
End If
' Move data from vector "temp" to vector "variable1"
ReDim variable1(1 To n)
For i = 1 To n
variable1(i) = temp(i)
Next
out "Variable 1 (" & combo1txt & ") prepared."
End Sub
'***********************************************************************************
Private Sub prepare2()
Dim i As Long
Dim n As Long
' Get variable part from combo box
combo2txt = getword(Combo2.text, 1, " ")
If combo2txt = "" Then Exit Sub
' Move data from vector with name combo1txt to vector "temp"
Call prepare_temp(combo2txt)
If Mid$(combo2txt, 1, 1) = "i" Then
n = m_icount
Else
n = m_hcount
End If
' Move data from vector "temp" to vector "variable1"
ReDim variable2(1 To n)
For i = 1 To n
variable2(i) = temp(i)
Next
out "Variable 2 (" & combo2txt & ") prepared."
End Sub
'***********************************************************************************
Private Sub cmdCompute_Click()
Call calculations
End Sub
'***********************************************************************************
Sub calculations()
Dim i As Long, n1 As Long, n2 As Long
Dim sum As Double
Dim condVal
Dim txtcondval As String
n1 = vectorsize(variable1)
n2 = vectorsize(variable2)
txtcondval = txtVal2.text
If txtcondval <> "" Then
condVal = CDbl(txtcondval)
out "Condition: " & combo2txt & " = " & txtcondval
End If
' Don't mix indiviudal and houshold variables
If txtcondval <> "" And n1 <> n2 Then Exit Sub
' Do calculations
sum = 0
For i = 1 To n1
' Case 1, no condtional value
If txtVal2 = "" Then
sum = sum + variable1(i)
' Case 2, conditional value
Else
If variable2(i) = condVal Then sum = sum + variable1(i)
End If
Next
' Show result
out "Sum of variable " & combo1txt & " = " & sum
End Sub
'***********************************************************************************
Sub out(txt)
'Append text to text box
resultbox.text = resultbox.text & vbCrLf & txt
' Position cursor to end of text
resultbox.SelStart = Len(resultbox.text)
resultbox.Refresh
End Sub
'***********************************************************************************
Private Sub Text1_Change()
' Uppdatera beräkning
If Combo1.text <> "" Then Call prepare1
If Combo2.text <> "" Then Call prepare2
Call calculations
End Sub
'***********************************************************************************
Function vectorsize(v)
On Error GoTo fel
vectorsize = UBound(v)
Exit Function
fel:
vectorsize = 0
End Function