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