VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "Inchistory"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private h As Integer
Private buff_inr(1 To 1000) As Long
Private buff_hnr(1 To 1000) As Long
Private buff_bald(1 To 1000) As Integer
Private buff_tid(1 To 1000) As Integer
Private buff_hevent(1 To 1000) As String * 30
Private mdbfil As String
Private init_done As Integer
'local variable(s) to hold property value(s)
Private menabled As Boolean 'local copy
' Routine to retrieve all historic income for an
' individual from income database
' Parameters:
' kod 0 = Open db for read and exit
' kod 1 = Fetch income for individual "individnr" and
' return income in global matrix income_vector
' with "n" rows and 3 colums:
' modeltime, status and income
' kod 2 = Close db and exit
Public Sub getinchist(kod, individnr, n)
Dim i As Long
Static db As Database
Static rs As Recordset
Dim dbfil As String
If menabled = False Then Exit Sub
n = 0
Erase income_vector
' Open db and exit
If kod = 0 Then
dbfil = mdbfil
Set db = OpenDatabase(dbfil)
Set rs = db.OpenRecordset("IncHist", dbOpenTable, dbReadOnly)
rs.index = "indnr"
Exit Sub
End If
' Close db and exit
If kod = 2 Then
rs.Close
db.Close
Exit Sub
End If
rs.Seek "=", individnr
If rs.NoMatch Then
Exit Sub
End If
i = 1
Do Until rs!indnr <> individnr
n = n + 1
income_vector(1, i) = rs!year
income_vector(2, i) = rs!status
income_vector(3, i) = rs!income
rs.MoveNext
If rs.EOF = True Then Exit Do
i = i + 1
Loop
End Sub
' Routine to retrieve all historic income for an
' individual from income database
' Parameters:
' kod 0 = Open db for read and exit
' kod 1 = Fetch income for individual "individnr" and
' return income in global matrix income_vector
' with "n" rows and 3 colums:
' modeltime, status and income
' kod 2 = Close db and exit
Public Sub getinchist2(kod, individnr, n)
Dim i As Long
Static db As Database
Static rs As Recordset
Dim dbfil As String
' If menabled = False Then Exit Sub
n = 0
Erase income_vector
' Open db and exit
If kod = 0 Then
dbfil = mdbfil
' Set db = OpenDatabase(dbfil)
Set db = OpenDatabase(sesimpath & "\microdata\history\sesimpp.mdb")
Set rs = db.OpenRecordset("IncHist", dbOpenTable, dbReadOnly)
'Set rs = db.OpenRecordset("pp", dbOpenTable, dbReadOnly)
rs.index = "indnr"
Exit Sub
End If
' Close db and exit
If kod = 2 Then
rs.Close
db.Close
Exit Sub
End If
rs.Seek "=", individnr
If rs.NoMatch Then
Exit Sub
End If
i = 1
Do Until rs!indnr <> individnr
n = n + 1
income_vector(1, i) = rs!year
income_vector(2, i) = rs!status
income_vector(3, i) = rs!income
rs.MoveNext
If rs.EOF = True Then Exit Do
i = i + 1
Loop
End Sub
Public Sub Init()
Dim ws As Workspace
Dim db As Database
Dim tb As TableDef
Dim findnr0 As Field
Dim findnr1 As Field
Dim findnr2 As Field
Dim findnr3 As Field
Dim findnr4 As Field
Dim findnr5 As Field
Dim newf As Field
Dim indnr_idx As index
If menabled = False Then Exit Sub
status "Create income database"
mdbfil = sesimpath & "\microdata\income_history.mdb"
If Dir(mdbfil) <> "" Then Kill mdbfil
Set ws = DBEngine.Workspaces(0)
'Set db = ws.CreateDatabase(mdbfil, dbLangGeneral, dbVersion30)
Set db = ws.CreateDatabase(mdbfil, dbLangGeneral, dbUseJet)
Set tb = db.CreateTableDef("IncHist")
Set findnr0 = tb.CreateField("year", dbInteger)
Set findnr1 = tb.CreateField("indnr", dbLong)
Set findnr2 = tb.CreateField("status", dbInteger)
Set findnr3 = tb.CreateField("income", dbDouble)
tb.Fields.Append findnr0
tb.Fields.Append findnr1
tb.Fields.Append findnr2
tb.Fields.Append findnr3
db.TableDefs.Append tb
Set indnr_idx = tb.CreateIndex("indnr")
indnr_idx.Primary = True
indnr_idx.Unique = False
Set newf = indnr_idx.CreateField("indnr")
indnr_idx.Fields.Append newf
tb.Indexes.Append indnr_idx
db.Close
init_done = 1
End Sub
Public Sub write_now()
Dim i As Long
Dim ws As Workspace
Dim db As Database
Dim rs As Recordset
Dim dbfil As String
If menabled = False Then Exit Sub
If init_done = 0 Then Call Init
Static last_modeltime_written As Integer
status "Writing income history..."
If model_time <= last_modeltime_written Then Call del_future
dbfil = mdbfil
Set ws = DBEngine.Workspaces(0)
Set db = ws.OpenDatabase(dbfil)
Set rs = db.OpenRecordset("IncHist", dbOpenTable, dbAppendOnly)
'monitor_events.Data1.ReadOnly = False
ws.BeginTrans
For i = 1 To m_icount
If i_age(i) >= 18 And i_age(i) <= 64 Then
With rs
.AddNew
!year = base_year + model_time
!indnr = i_indnr(i)
!status = i_status(i)
!income = i_inc_taxable(i)
.Update
End With
End If
Next
ws.CommitTrans
' ws.Rollback
rs.Close
db.Close
ws.Close
last_modeltime_written = model_time
status "Income history written"
'monitor_events.Data1.ReadOnly = True
End Sub
Public Sub del_future()
Dim db As Database
Dim dbfil As String
Dim del_str As String
' status "Deleting future"
dbfil = mdbfil
Set db = OpenDatabase(dbfil)
del_str = "delete * from inchist where year >= " & CStr(base_year + model_time)
db.Execute del_str
db.Close
' status "Deleting future done"
End Sub
Public Property Let enabled(ByVal vData As Boolean)
menabled = vData
End Property
Public Property Get enabled() As Boolean
enabled = menabled
End Property
' Income history is currently not used in SESIM.
' But here is an example how to fetch incomes
' from the database.
' Dim i As Long
' Dim antal As Long
' status "Reading hist"
' ' open db for read
' Call inchist.getinchist(0, 0, antal)
' For i = 1 To m_icount
' ' Fetch complete income history for people
' ' aged 65. (for example for calculation of pension)
' If i_age(i) = 65 Then
' Call inchist.getinchist(1, i_indnr(i), antal)
' End If
' Next
' ' close db
' Call inchist.getinchist(2, 0, antal)
' status "Done"