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"