VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END 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 db.Close 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