MultiUse = -1  'True
Attribute VB_Name = "Lifehistory"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
Private h As Integer
Private buff_inr(1 To 1000) As Long
Private buff_hnr(1 To 1000) As Long
Private buff_sex(1 To 1000) As Integer
Private buff_age(1 To 1000) As Integer
Private buff_time(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
Public Property Let enabled(ByVal vData As Boolean)
    menabled = vData
End Property

Public Property Get enabled() As Boolean
Attribute enabled.VB_UserMemId = 0
    enabled = menabled
End Property
' Init and create db

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 findnr6 As Field
   Dim newf As Field
   Dim indnr_idx As Index
   If menabled = False Then Exit Sub
   mdbfil = sesimpath & "\microdata\event_history.mdb"
   status "Create event history database"
   If Dir(mdbfil) <> "" Then Kill mdbfil
   Set ws = DBEngine.Workspaces(0)
   Set db = ws.CreateDatabase(mdbfil, dbLangGeneral, dbVersion30)
   Set tb = db.CreateTableDef("Hist")
   ' Event number
   Set findnr0 = tb.CreateField("Eventnr", dbLong)
   findnr0.Attributes = dbAutoIncrField
   Set findnr1 = tb.CreateField("Indnr", dbLong)
   Set findnr2 = tb.CreateField("Hhnr", dbLong)
   Set findnr3 = tb.CreateField("Sex", dbInteger)
   Set findnr4 = tb.CreateField("Age", dbLong)
   Set findnr5 = tb.CreateField("ModelTime", dbInteger)
   Set findnr6 = tb.CreateField("Event", dbText)
   findnr3.Size = 30
   tb.Fields.Append findnr0
   tb.Fields.Append findnr1
   tb.Fields.Append findnr2
   tb.Fields.Append findnr3
   tb.Fields.Append findnr4
   tb.Fields.Append findnr5
   tb.Fields.Append findnr6
   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

   init_done = 1
End Sub

Public Sub write_hist(inr As Long, hevent As String) If menabled = False Then Exit Sub If init_done = 0 Then Call Init h = h + 1 buff_inr(h) = inr buff_hnr(h) = 0 If indnr2index(inr) > 0 Then buff_hnr(h) = i_hhnr(indnr2index(inr)) buff_sex(h) = 0 If indnr2index(inr) > 0 Then buff_sex(h) = i_sex(indnr2index(inr)) buff_age(h) = 0 If indnr2index(inr) > 0 Then buff_age(h) = i_age(indnr2index(inr)) buff_time(h) = model_time buff_hevent(h) = hevent ' Write buffer If h = 1000 Then write_now End Sub
' Write buffer to db
Public Sub write_now() Dim i As Integer Dim db As Database Dim rs As Recordset If menabled = False Then Exit Sub status "Writing event history..." Set db = OpenDatabase(mdbfil) Set rs = db.OpenRecordset("Hist", dbOpenTable, dbAppendOnly) For i = 1 To h With rs .AddNew !indnr = buff_inr(i) !hhnr = buff_hnr(i) !sex = buff_sex(i) !age = buff_age(i) !modeltime = buff_time(i) !event = buff_hevent(i) .Update End With Next db.Close h = 0 'controlcenter.cmd3Lifeevents.enabled = True status "History written" End Sub