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