CODE SAMPLE
Lines preceded by a ' are comment not executable code.
Public Function CreateFlatFile() As Boolean
'FOR USE IN HISTORIC MINING JOURNAL INDEX DATABASE
'This function creates a "flat file" recordset of mines and page numbers as row values from multiple page number records relative to each mine
'It populates a table type recordset "Journal"
'That table is then called into a query with information from the "Mines" table recordset as source data for a report or output to Word or Excel
'Returns true if successful
'OUTPUTS ALL FILTERED BY VOLUME
'Copyright© 2009 Roy Fellows, Iris Computers Ltd
'Declare all data types
Dim lngMineID As Long
Dim strPages As String
Dim strSQL As String
Dim strSQL2 As String
Dim qdf As QueryDef
Dim strDocName As String
Dim strDocName2 As String
Dim intVolume As Integer
Dim strCharacterRef As String
Dim dbs As Database
Dim rst As Recordset
Dim rst2 As Recordset
Dim rst3 As Recordset
Dim msg As String
strDocName = "MinesByVol"
strDocName2 = "PagesByVol"
'Get the volume from user dialog box
intVolume = Forms!CreateFlatFile!Volume
'Error trapping routine
Const mnErrDivByZero = 11, mnErrOverFlow = 6, mnErrBadCall = 5
On Error GoTo TrapErrors
'Create a query recordset of mines with page entries filtered to the relevant year
'Faster than using DAO with a WHERE clause
strSQL = "SELECT Pages.MineID, Pages.VolNo FROM Pages GROUP BY Pages.MineID, Pages.VolNo HAVING (((Pages.MineID) Is Not Null) And ((Pages.VolNo)=" & intVolume & "))ORDER BY Pages.MineID;"
Set dbs = CurrentDb
Set qdf = dbs.CreateQueryDef(strDocName, strSQL)
'
'Loop through each record in "MinesByVol" gathering information and incrementing the string value strPages
Set rst = dbs.OpenRecordset(strDocName)
'Go to first record
rst.MoveFirst
Do
'Parse each record in "MinesByVol" getting values, then add a new record to "Journal" to create the flat file database
'Set initial value of string variable strPages
strPages = ""
lngMineID = rst!MineID
'Second query is recreated with each run of the loop and is filtered by mine and year
'Year remains constant, but MineID changes on each cycle
strSQL2 = "SELECT Pages.MineID, Pages.ActualPageNo, Pages.LogicalPageNo, Pages.SeveralEntries, EntryTypes.CharacterRef FROM EntryTypes INNER JOIN Pages ON EntryTypes.TypeID = Pages.EntryTypeID WHERE (((Pages.MineID)=" & lngMineID & "AND ((Pages.VolNo)=" & intVolume & ")))ORDER BY Pages.LogicalPageNo;"
Set qdf = dbs.CreateQueryDef(strDocName2, strSQL2)
Set rst2 = dbs.OpenRecordset(strDocName2)
rst2.MoveFirst
Do
If rst2!CharacterRef = "#" Then
strCharacterRef = ""
Else
strCharacterRef = "(" & rst2!CharacterRef & ")"
End If
If rst2!SeveralEntries = True Then
strCharacterRef = strCharacterRef & "*"
End If
strPages = strPages & rst2!ActualPageNo & strCharacterRef & ", "
rst2.MoveNext
Loop Until rst2.EOF
'Delete the query ready for its re-concatenation on the next loop cycle
DoCmd.DeleteObject acQuery, strDocName2
Set rst3 = dbs.OpenRecordset("Journal")
'Open the table named "Journal", then add a new record with all the gen
'When the report that this is all about closes, it will delete all the records in "Journal" ready for the next time
With rst3
.AddNew
!MineID = lngMineID
!Pages = strPages
.Update
.Close
End With
rst.MoveNext
Loop Until rst.EOF
'Delete the first query, its usefulness has passed.
DoCmd.DeleteObject acQuery, strDocName
'Return true if successful
CreateFlatFile = True
' If there is a an error that brings everything to a halt, return false and get out of Dodge. Otherwise advise user, record details in the error log, then resume execution of the code.
'You wont get a div by zero but its still looks good!
Exit Function
TrapErrors:
If Err.Number = mnErrDivByZero Or Err.Number = mnErrOverFlow Or Err.Number = mnErrBadCall Then
CreateFlatFile = False
Else
msg = "Unanticipated error " & Err.Number
msg = msg & ": " & Err.Description
MsgBox msg, vbExclamation, , "Historic Mining Journal"
Dim errObj As Error, strP As String
strP = "CreateFlatFile"
RecordErrors Err, strP
Err.Clear
Resume Next
End If
End Function
Strictly Copywrite Roy Fellows 2015
My avatar is a poor likeness.