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"