VERSION 5.00 Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX" Begin VB.Form report_ed Caption = "Report" ClientHeight = 5250 ClientLeft = 60 ClientTop = 630 ClientWidth = 8430 LinkTopic = "Form1" MDIChild = -1 'True ScaleHeight = 5250 ScaleWidth = 8430 Begin VB.TextBox Text1 Height = 375 Left = 5880 TabIndex = 2 Text = "Text1" Top = 3120 Width = 615 Visible = 0 'False End Begin RichTextLib.RichTextBox rtbEd Height = 1575 Left = 0 TabIndex = 0 Top = 3600 Width = 8415 _ExtentX = 14843 _ExtentY = 2778 _Version = 393217 Enabled = -1 'True ScrollBars = 3 TextRTF = $"report_ed.frx":0000 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Courier New" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty End Begin RichTextLib.RichTextBox rtbOutput Height = 3375 Left = 0 TabIndex = 1 Top = 0 Width = 8415 _ExtentX = 14843 _ExtentY = 5953 _Version = 393217 Enabled = -1 'True ScrollBars = 2 TextRTF = $"report_ed.frx":00E2 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Courier New" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty End Begin VB.Menu menu_help Caption = "Help" End End Attribute VB_Name = "report_ed" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Base 1 Dim locals_name() As String Dim locals_value() As Double Dim locals_n As Integer Dim last_if As Boolean Sub eval_line(strLine0) Dim i As Long strline = LCase(strLine0) If Left(strline, 8) = "clear if" Then last_if = True Exit Sub End If If Left(strline, 6) = "loopif" Then Dim lstr0 As String 'Dim lstr1 As String Dim lstrif As String Dim lstrdo As String lstr0 = Mid(strline, 8) pos_then = InStr(1, lstr0, "then") lstrif = Left(lstr0, pos_then - 1) lstrdo = Mid(lstr0, pos_then + 5) 'rtbOutput.Visible = False For i = 1 To m_icount last_if = True Call eval_line("if " & Replace(lstrif, "(i)", "(" & CStr(i) & ")")) Call eval_line(Replace(lstrdo, "(i)", "(" & CStr(i) & ")")) Next 'rtbOutput.Visible = True Exit Sub End If If Left(strline, 1) = "z" Then For i = 1 To Int(m_icount / 2) select_i(i) = 0 Next Exit Sub End If If Left(strline, 1) = "q" Then For i = 1 To m_icount select_i(i) = 1 Next Exit Sub End If pos_set = InStr(1, strLine0, "=") pos_if = InStr(1, strLine0, "if") If pos_if = 1 Then pos_set = 0 End If If pos_set = 0 And pos_if = 0 Then strline2 = exp_expr(strline) ElseIf pos_set > 0 Then strline2 = exp_expr(Replace(Mid(strline, pos_set + 1), " ", "")) ElseIf pos_if = 1 Then strline2 = exp_expr(Replace(Mid(strline, pos_if + 3), " ", "")) End If ' Replace vector functions strline2 = eval_functions(strline2) Dim y As Double If pos_set = 0 Then If e_eval(strline2, y) Then If pos_if <> 1 Then 'out last_if If last_if = True Then out strline & " = " & y End If Else Dim yres As String yres = y If y = "0" Then yres = "False" last_if = False End If If y = "-1" Then yres = "True" out strline & " = " & yres End If Else out "Error: " & strLine0 End If Else If e_eval(strline2, y) Then Call store_local(Left(strline, pos_set - 1), y) End If End If If Left(strline, 6) = "print " Then strExpr = Mid(strline, 7) End If End Sub
''' Functions operating on Sesim's individual and household vectors Function eval_functions(strExpr) Dim strF As String Dim strVartype As String strF = strExpr posfunc = InStr(1, strF, "sum(") Do While posfunc > 0 posvpar = InStr(posfunc, strF, "(") poshpar = InStr(posvpar, strF, ")") func_var = Mid(strF, posvpar + 1, poshpar - posvpar - 1) strVartype = var_type(func_var) If strVartype = "i" Or strVartype = "h" Then vsum = 0 Call prepare_temp(func_var) If strVartype = "i" Then vcount = m_icount If strVartype = "h" Then vcount = m_hcount For i = 1 To vcount vsum = vsum + temp(i) Next strF = Replace(strF, Mid(strF, posfunc, poshpar - posfunc + 1), CStr(vsum)) End If posfunc = InStr(poshpar, strF, "sum(") Loop posfunc = InStr(1, strF, "mean(") Do While posfunc > 0 posvpar = InStr(posfunc, strF, "(") poshpar = InStr(posvpar, strF, ")") func_var = Mid(strF, posvpar + 1, poshpar - posvpar - 1) strVartype = var_type(func_var) If strVartype = "i" Or strVartype = "h" Then vsum = 0 Call prepare_temp(func_var) If strVartype = "i" Then vcount = m_icount If strVartype = "h" Then vcount = m_icount For i = 1 To vcount vsum = vsum + temp(i) Next strF = Replace(strF, Mid(strF, posfunc, poshpar - posfunc + 1), CStr(vsum / vcount)) End If posfunc = InStr(poshpar, strF, "mean(") Loop eval_functions = strF End Function
Function exp_expr(strExpr) Dim res1 As String Dim ggr As Integer res1 = x_exp_expr(strExpr) res2 = "" Do Until res1 = res2 ggr = ggr + 1 res2 = res1 res1 = x_exp_expr(res2) If ggr > 10 Then Exit Do Loop '' Check for functions 'If InStr(1, res1, "sum(") > 0 Then ' 'End If exp_expr = res1 End Function
Function x_exp_expr(strExpr) Dim str1 As String str1 = strExpr str2 = Replace(str1, "+", "@") str2 = Replace(str2, "-", "@") str2 = Replace(str2, "*", "@") str2 = Replace(str2, "/", "@") str2 = Replace(str2, "(", "@") str2 = Replace(str2, ")", "@") str2 = Replace(str2, "<", "@") str2 = Replace(str2, ">", "@") str2 = Replace(str2, "=", "@") 'str2 = Replace(str2, "[", "@") 'str2 = Replace(str2, "]", "@") parts = Split(str2, "@") '''out str2 If IsArray(parts) Then For i = 0 To UBound(parts) If Len(parts(i)) > 0 Then strVartype = var_type(parts(i)) If strVartype = "l" Then str1 = ReplaceWord(str1, CStr(parts(i)), get_local(parts(i))) End If If strVartype = "m" Then str1 = ReplaceWord(str1, CStr(parts(i)), CStr(get_macro_value(parts(i)))) End If If strVartype = "i" Or strVartype = "h" Then ' next part must be index If i < UBound(parts) Then If IsNumeric(parts(i + 1)) Then indexnr = CLng(parts(i + 1)) str1 = ReplaceWord(str1, CStr(parts(i) & "(" & CStr(indexnr) & ")"), CStr(get_value(parts(i), indexnr))) End If End If End If 'out var_type(parts(i)) & " " & parts(i) End If Next End If x_exp_expr = str1 End Function
Function var_type(strConst) var_type = "u" If IsNumeric(strConst) Then var_type = "n" Exit Function ElseIf is_local(strConst) Then var_type = "l" Exit Function ElseIf Left(strConst, 2) = "m_" Then For Each cv In mvar_coll If strConst = cv Then var_type = "m" Exit Function End If Next ElseIf Left(strConst, 2) = "i_" Then For Each cv In var_coll If strConst = cv Then var_type = "i" Exit Function End If Next ElseIf Left(strConst, 2) = "h_" Then For Each cv In var_coll If strConst = cv Then var_type = "h" Exit Function End If Next End If End Function
Private Sub Form_Load() Call readdata last_if = True End Sub
Private Sub Form_Resize() hojd = Me.Height bredd = Me.Width rtbOutput.Top = 10 rtbOutput.Height = 0.6 * hojd rtbOutput.Width = bredd - 20 rtbEd.Top = 20 + rtbOutput.Height rtbEd.Height = maxi(0, hojd - rtbOutput.Height - 500) rtbEd.Width = bredd - 20 End Sub
Private Sub rtbed_KeyDown(KeyCode As Integer, Shift As Integer) 'MsgBox KeyCode If KeyCode = vbKeyF8 Then A = getline() End If End Sub
Function getline() 'MsgBox rtbEd.SelStart pos = rtbEd.SelStart + 1 'out (pos) ' out (rtbOutput.SelStart) 'Exit Function slut = InStr(pos, rtbEd.text, vbCrLf) - 1 If slut <= 0 Then slut = Len(rtbEd.text) If slut = 0 Then Exit Function 'out ("slut " & slut) Start = InStrRev(rtbEd.text, vbCrLf, slut) If Start = 0 Then Start = 1 Else Start = Start + 2 End If 'out ("start " & start) txt = Mid$(rtbEd.text, Start, slut - Start + 1) 'out txt Call eval_line(txt) End Function
Sub out(txt) 'rtbOutput.text = rtbOutput.text & vbCrLf & ">" & txt & "<" rtbOutput.text = rtbOutput.text & vbCrLf & txt 'rtbOutput.SetFocus rtbOutput.SelStart = Len(rtbOutput.text) 'rtbEd.SetFocus End Sub
Private Sub Text1_Change() Dim strLines last_if = True strLines = Split(rtbEd.text, vbCrLf) If IsArray(strLines) Then For i = 0 To UBound(strLines) If strLines(i) <> "" Then 'out "[" & strLines(i) & "]" Call eval_line(strLines(i)) End If Next End If 'Call getline End Sub
Private Sub readdata() If Dir(sesimpath & "\parameterdata\rtbed.txt") <> "" Then fnum = FreeFile Open sesimpath & "\parameterdata\rtbed.txt" For Input As fnum rtbEd.text = Input(LOF(fnum), #fnum) Close fnum End If End Sub
Private Sub store_local(strName, dblValue) Dim i As Integer For i = 1 To locals_n If locals_name(i) = strName Then locals_value(i) = dblValue Exit Sub End If Next locals_n = locals_n + 1 ReDim Preserve locals_name(locals_n) ReDim Preserve locals_value(locals_n) locals_name(locals_n) = strName locals_value(locals_n) = dblValue End Sub
Private Function is_local(strName) As Boolean Dim i As Integer For i = 1 To locals_n If locals_name(i) = strName Then is_local = True Exit Function End If Next is_local = False End Function
Private Function get_local(strName) As Double Dim i As Integer For i = 1 To locals_n If locals_name(i) = strName Then get_local = locals_value(i) Exit Function End If Next End Function
Private Sub Form_Unload(Cancel As Integer) coll_view.Remove Me.Tag fnum = FreeFile Open sesimpath & "\parameterdata\rtbed.txt" For Output As fnum Print #fnum, rtbEd.text Close fnum End Sub
Private Sub menu_help_Click() out "Help:" out "Statement without '=' or 'if' -> print" out " example: i_age(1)" out "Statement with 'if' -> logical expression" out "Statement with '=' -> set variable" out " example: test=1" out "F8, evaluate current row" out "F5, evaluate all rows" End Sub