VERSION 5.00
Begin VB.Form zsesimDDE
Caption = "sesimDDE"
ClientHeight = 4770
ClientLeft = 60
ClientTop = 345
ClientWidth = 5730
LinkMode = 1 'Source
LinkTopic = "sesimDDE"
MDIChild = -1 'True
ScaleHeight = 4770
ScaleWidth = 5730
WindowState = 1 'Minimized
Begin VB.TextBox Text2
Height = 345
Left = 300
LinkItem = "R1C2"
LinkTopic = "excel|sesim"
TabIndex = 2
Text = $"edmodDDE.frx":0000
Top = 540
Width = 3975
End
Begin VB.ListBox List1
Height = 1815
Left = 300
TabIndex = 1
Top = 1560
Width = 3975
End
Begin VB.TextBox Text1
Height = 345
Left = 300
LinkItem = "Text1"
TabIndex = 0
Top = 60
Width = 3975
End
End
Attribute VB_Name = "zsesimDDE"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'**************************************************
' This module is serving the Excel report generator
' Syntax på ingående kommandosträng
' åtskilda med tecknet ¤
' 1-4 är nödvändiga, 5-7 optional
' 1. Resultatvariabel
' 2. Destination i Excel (format r1c1)
' 3. Statistika
' 4. År
' 5. Selekteringsvariabel
' 6. Selekteringsoperator
' 7. Selekteringsvärde
Option Explicit
Dim result As Variant
Dim selection_vector() As Integer
Dim selection_active As Integer
Private Sub Text1_Change()
Dim txt1 As String, txt2 As String
Dim i As Integer, sun_delim As Integer
If Text1.text = "" Then Exit Sub
If Left$(Text1.text, 3) = "End" Then Text1.text = ""
' Manuellt läge
If Left$(Text1.text, 1) = "_" Then Exit Sub
If init_done = 0 Then Call Initsesim
' Selection
If Left$(Text1.text, 1) = "!" Then
Call set_selection(Text1.text)
Exit Sub
End If
If Text1.text = "" Then Exit Sub
txt1 = Text1.text
' look for delimiter
sun_delim = InStr(1, txt1, "¤")
If sun_delim = 0 Then
Exit Sub
End If
' Exit if variable does not exist
If getword(txt1, 1, "¤") <> "[dummy]" Then
If lookup_var(getword(txt1, 1, "¤")) = False Then Exit Sub
End If
txt2 = ""
For i = 1 To Len(txt1)
If Asc(Mid$(txt1, i, 1)) < 32 Then Exit For
txt2 = txt2 & Mid$(txt1, i, 1)
Next
If txt2 = "" Then Exit Sub
Call compute(txt2)
Text1.text = ""
' If List1.ListCount > 0 Then
' Dim txt3 As String
' txt3 = List1.List(0)
' List1.RemoveItem 0
' Text1.text = txt3
' End If
End Sub
Sub compute(txt)
Dim j As Integer, exc_year As Integer, comp_case As Integer, opcase As Integer
Dim sum As Double, mean As Double, opvalnum As Double
Dim statistika As String
Dim countvalue As Long, countfreq As Long, i As Long, n As Long, nn As Long
Dim var1 As String, var2 As String, op As String, opval As String
Dim par(1 To 7) As String
'*** Separate the command parameters
For i = 1 To 7
par(i) = LCase(getword(txt, i, "¤"))
Next
'*** If no return position is given then exit
If par(2) = "" Then
MsgBox "Error in Excel return location"
Exit Sub
End If
'*** Make sure that the linktopix is OK before setting the mode
If par(2) = "#" Then
'*** The temporary sheet "temp" always exists
Text2.LinkTopic = "excel|temp"
Else
Text2.LinkTopic = "excel|" & getword(par(2), 1, "_")
End If
Text2.LinkMode = 2
statistika = par(3) '*** Statistic
exc_year = par(4) '*** Current year of analysis
If Not IsNumeric(exc_year) Then
MsgBox "Error in year"
Exit Sub
End If
var1 = par(1) '*** Analysis variable
var2 = par(5) '*** Selection variable
op = par(6) '*** Selection operator
opval = par(7) '*** Selection value
'*** Goto year
If exc_year <> base_year + model_time Then
If binary_files_exist(exc_year - base_year) = True Then
status "Change to time" & CStr(exc_year - base_year)
Call read_data(exc_year - base_year)
controlcenter.antalindivider.Caption = m_icount
controlcenter.antalhushåll.Caption = m_hcount
Call controlcenter.update_viewers
status "Done"
Else
If exc_year > base_year + model_time Then
i = exc_year - (base_year + model_time)
controlcenter.comb1Yearstorun.text = CStr(i) & " year"
controlcenter.cmd1run_Click
Else
status "Restart is needed - no saved files"
Call Initsesim
i = exc_year - (base_year + model_time)
controlcenter.comb1Yearstorun.text = CStr(i) & " year"
controlcenter.cmd1run_Click
End If
End If
End If
'*** If the analysis variable is set to [dummy] then exit after having
'*** changed the year.
If var1 = "[dummy]" Then Exit Sub
' Exit if the user pressed stop
If exc_year <> base_year + model_time Then
Exit Sub
End If
' If macro variable
If Mid$(var1, 1, 1) = "m" Then
Text2.LinkItem = par(2)
If statistika = "sum99" Then
result = get_macro_value(var1) * m_price99
Else
result = get_macro_value(var1)
End If
'*** Write the result back to Excel and then exit the sub
Text2.text = result
Text2.LinkPoke
Exit Sub
End If
If Mid$(var1, 1, 1) = "i" Then n = m_icount
If Mid$(var1, 1, 1) = "h" Then n = m_hcount
If n = 0 Then
MsgBox "Error in variable name: " & var1
Exit Sub
End If
'*** If there exists a selection variable
If var2 <> "#" Then
Call prepare_temp(var2)
For i = 1 To n
temp2(i) = temp(i)
Next
End If
'*** Prepare the analysis variable.
Call prepare_temp(var1)
'*** No conditions
comp_case = 1
'*** Conditions on the analysis variable
If var2 = "#" And op <> "#" And opval <> "#" And IsNumeric(opval) Then
opcase = 0
Select Case op
Case "gt"
opcase = 1
Case "ge"
opcase = 2
Case "lt"
opcase = 3
Case "le"
opcase = 4
Case "ne"
opcase = 5
Case "eq"
opcase = 6
End Select
If opcase > 0 Then comp_case = 2
End If
'*** Conditions on the selection variable
If var2 <> "#" And op <> "#" And opval <> "#" And IsNumeric(opval) Then
opcase = 0
Select Case op
Case "gt"
opcase = 1
Case "ge"
opcase = 2
Case "lt"
opcase = 3
Case "le"
opcase = 4
Case "ne"
opcase = 5
Case "eq"
opcase = 6
End Select
If opcase > 0 Then comp_case = 3
End If
Dim nsel As Double
Dim dummy As Integer
Select Case comp_case
'*** No conditions
Case 1
Select Case statistika
Case "mean", "mean99", "sum", "sum99"
sum = 0
mean = 0
nsel = 0
If selection_active = 0 Then
For i = 1 To n
sum = sum + temp(i)
nsel = nsel + 1
Next
If nsel > 0 Then mean = sum / nsel
Else
For i = 1 To n
sum = sum + temp(i) * selection_vector(i)
nsel = nsel + selection_vector(i)
Next
'If n > 0 Then mean = sum / n
If nsel > 0 Then mean = sum / nsel
End If
Case "count"
countfreq = 0
countvalue = 0
If selection_active = 0 Then
For i = 1 To n
If CLng(temp(i)) > countvalue Then countfreq = countfreq + 1
Next
Else
For i = 1 To n
If CLng(temp(i)) > countvalue Then countfreq = countfreq + selection_vector(i)
Next
End If
End Select
'*** Conditions on the analysis variable
Case 2
opvalnum = CVar(opval)
If selection_active = 0 Then dummy = 1
Select Case statistika
Case "mean", "mean99", "sum", "sum99"
sum = 0
mean = 0
nn = 0
For i = 1 To n
If selection_active = 1 Then
dummy = 0
If selection_vector(i) = 1 Then dummy = 1
End If
Select Case opcase
Case 1
If temp(i) > opvalnum Then
sum = sum + temp(i) * dummy
nn = nn + 1 * dummy
End If
Case 2
If temp(i) >= opvalnum Then
sum = sum + temp(i) * dummy
nn = nn + 1 * dummy
End If
Case 3
If temp(i) < opvalnum Then
sum = sum + temp(i) * dummy
nn = nn + 1 * dummy
End If
Case 4
If temp(i) <= opvalnum Then
sum = sum + temp(i) * dummy
nn = nn + 1 * dummy
End If
Case 5
If temp(i) <> opvalnum Then
sum = sum + temp(i) * dummy
nn = nn + 1 * dummy
End If
Case 6
If temp(i) = opvalnum Then
sum = sum + temp(i) * dummy
nn = nn + 1 * dummy
End If
End Select
Next
If nn > 0 Then mean = sum / nn
Case "count"
countfreq = 0
For i = 1 To n
If selection_active = 1 Then
dummy = 0
If selection_vector(i) = 1 Then dummy = 1
End If
Select Case opcase
Case 1
If temp(i) > opvalnum Then countfreq = countfreq + 1 * dummy
Case 2
If temp(i) >= opvalnum Then countfreq = countfreq + 1 * dummy
Case 3
If temp(i) < opvalnum Then countfreq = countfreq + 1 * dummy
Case 4
If temp(i) <= opvalnum Then countfreq = countfreq + 1 * dummy
Case 5
If temp(i) <> opvalnum Then countfreq = countfreq + 1 * dummy
Case 6
If temp(i) = opvalnum Then countfreq = countfreq + 1 * dummy
End Select
Next
End Select
'*** Conditions on the selection variable
Case 3
opvalnum = CVar(opval)
If selection_active = 0 Then dummy = 1
Select Case statistika
Case "mean", "mean99", "sum", "sum99"
sum = 0
mean = 0
nn = 0
For i = 1 To n
If selection_active = 1 Then
dummy = 0
If selection_vector(i) = 1 Then dummy = 1
End If
Select Case opcase
Case 1
If temp2(i) > opvalnum Then
sum = sum + temp(i) * dummy
nn = nn + 1 * dummy
End If
Case 2
If temp2(i) >= opvalnum Then
sum = sum + temp(i) * dummy
nn = nn + 1 * dummy
End If
Case 3
If temp2(i) < opvalnum Then
sum = sum + temp(i) * dummy
nn = nn + 1 * dummy
End If
Case 4
If temp2(i) <= opvalnum Then
sum = sum + temp(i) * dummy
nn = nn + 1 * dummy
End If
Case 5
If temp2(i) <> opvalnum Then
sum = sum + temp(i) * dummy
nn = nn + 1 * dummy
End If
Case 6
If temp2(i) = opvalnum Then
sum = sum + temp(i) * dummy
nn = nn + 1 * dummy
End If
End Select
Next
If nn > 0 Then mean = sum / nn
Case "count"
countfreq = 0
For i = 1 To n
If selection_active = 1 Then
dummy = 0
If selection_vector(i) = 1 Then dummy = 1
End If
Select Case opcase
Case 1
If temp2(i) > opvalnum Then countfreq = countfreq + 1 * dummy
Case 2
If temp2(i) >= opvalnum Then countfreq = countfreq + 1 * dummy
Case 3
If temp2(i) < opvalnum Then countfreq = countfreq + 1 * dummy
Case 4
If temp2(i) <= opvalnum Then countfreq = countfreq + 1 * dummy
Case 5
If temp2(i) <> opvalnum Then countfreq = countfreq + 1 * dummy
Case 6
If temp2(i) = opvalnum Then countfreq = countfreq + 1 * dummy
End Select
Next
End Select
End Select
Select Case statistika
Case "mean"
result = mean
Case "mean99"
result = mean * m_price99
Case "sum"
result = sum * m_weight
Case "sum99"
result = sum * m_weight * m_price99
Case "count"
result = countfreq * m_weight
End Select
'*** Write the results back to Excel
Text2.LinkItem = getword(par(2), 2, "_")
Text2.text = result
Text2.LinkPoke
End Sub
Function lookup_var(txt) As Boolean
Dim c
lookup_var = False
For Each c In var_coll
If c = txt Then
lookup_var = True
Exit Function
End If
Next
For Each c In mvar_coll
If c = txt Then
lookup_var = True
Exit Function
End If
Next
End Function
Private Sub set_selection(txt)
Dim var As String, op As String, opvaltxt As String
Dim opcase As Integer, first_selection As Integer
Dim opval As Double, n As Double
Dim i As Long
var = getword(txt, 5, "¤")
op = getword(txt, 6, "¤")
opvaltxt = getword(txt, 7, "¤")
If IsNumeric(opvaltxt) Then opval = opvaltxt
'*** Instruktion to clear selection
If var = "clear" Then
selection_active = 0
Erase selection_vector
Exit Sub
End If
'*** Exit if variable does not exist
If lookup_var(var) = False Then Exit Sub
'*** Exit if not i-variable
If Left$(var, 1) <> "i" Then Exit Sub
If Left$(var, 1) = "i" Then n = m_icount
If Left$(var, 1) = "h" Then n = m_hcount
If selection_active = 0 Then
ReDim selection_vector(1 To n)
first_selection = 1
End If
Call prepare_temp(var)
Select Case op
Case "gt"
opcase = 1
Case "ge"
opcase = 2
Case "lt"
opcase = 3
Case "le"
opcase = 4
Case "ne"
opcase = 5
Case "eq"
opcase = 6
End Select
Dim dummy As Integer
For i = 1 To n
dummy = 0
Select Case opcase
Case 1
If temp(i) > opval Then dummy = 1
Case 2
If temp(i) >= opval Then dummy = 1
Case 3
If temp(i) < opval Then dummy = 1
Case 4
If temp(i) <= opval Then dummy = 1
Case 5
If temp(i) <> opval Then dummy = 1
Case 6
If temp(i) = opval Then dummy = 1
End Select
If first_selection = 1 Then
selection_vector(i) = dummy
Else
selection_vector(i) = selection_vector(i) * dummy
End If
Next
If Left$(var, 1) = "i" Then selection_active = 1
End Sub