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