Create temporary MDB for temporary tables

Function BldTempTables() As Boolean
  '============================================================
  '  Programmer: DHookom
  '  Revision #:
  ' Called From:
  '        Date: 7/5/01
  '  Parameters:
  '============================================================
    On Error GoTo BldTempTables_Err
    Dim strErrMsg As String 'For Error Handling

    'Dim the objects
    Dim dbThis As DAO.Database
    Dim dbTemp As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim ndx As DAO.Index
    Dim rsStruct As DAO.Recordset   'the struct table
    
    'Dim the variables
    Dim strFolder As String         'the folder this application is located in
    Dim strThisDBName As String     'the name of this MDB
    Dim strTempDBName As String     'The name of the temp mdb
    Dim strTableName As String      'the table name
    
    Set dbThis = CurrentDb
    strThisDBName = dbThis.Name
    strFolder = Left(strThisDBName, Len(strThisDBName) - _ 
                Len(Dir(strThisDBName)))
    strTempDBName = strFolder & "PrdRptTemp.MDB"
    On Error Resume Next
    Kill strTempDBName 'if the old one exists, delete it
    On Error GoTo BldTempTables_Err
    'Create the new empty database
    Set dbTemp = CreateDatabase(strTempDBName, dbLangGeneral)
    Set rsStruct = dbThis.OpenRecordset("Select TableName, FieldName, " & _
            "FieldType, FieldSize, Indexed " & _
            "FROM ztblTempStructure ORDER BY TableName")
    With rsStruct
        If Not .EOF Then
            .MoveFirst
            Do Until .EOF
                strTableName = !TableName
                Set tdf = dbTemp.CreateTableDef(strTableName)
                Do Until !TableName <> strTableName
                    Select Case !FieldType
                        Case dbText
                            Set fld = tdf.CreateField(!FieldName, _
                                     !FieldType, !FieldSize)
                            fld.AllowZeroLength = True
                        Case Else
                            Set fld = tdf.CreateField(!FieldName, !FieldType)
                    End Select
                    
                    tdf.Fields.Append fld
                    tdf.Fields.Refresh
                    .MoveNext
                    If .EOF Then
                        Exit Do
                    End If
                Loop
                dbTemp.TableDefs.Append tdf
                dbTemp.TableDefs.Refresh
    
            Loop
        End If
        .Close
    End With
    
    'Create the indexes
    Set rsStruct = dbThis.OpenRecordset("Select TableName, FieldName, " & _
            "FieldType, Indexed, PrimaryKey " & _
            "FROM ztblTempStructure " & _
            "WHERE Indexed = -1 OR PrimaryKey = -1 ORDER BY TableName")
    With rsStruct
        .MoveFirst
        If Not .EOF Then
            .MoveFirst
            Do Until .EOF
                Set tdf = dbTemp.TableDefs(!TableName)
                'Debug.Print tdf.Name
                strTableName = !TableName
                Do Until !TableName <> strTableName
                    'Debug.Print "-" & !FieldName
                    Set ndx = tdf.CreateIndex(!FieldName)
                    Set fld = ndx.CreateField(!FieldName, !FieldType)
                    ndx.Fields.Append fld
                    'set up the primary key Field.
                    If !PrimaryKey = True Then
                        ndx.Primary = True
                    End If
                    tdf.Indexes.Append ndx
                    tdf.Indexes.Refresh
                    .MoveNext
                    If .EOF Then
                        Exit Do
                    End If
                Loop
            Loop
        End If
        .Close
    End With
    Set rsStruct = dbThis.OpenRecordset("Select Distinct TableName " & _
                 "From ztblTempStructure")
    'relink the tables
    With rsStruct
        .MoveFirst
        Do Until .EOF
            DoCmd.DeleteObject acTable, !TableName
            DoCmd.TransferDatabase acLink, "Microsoft Access", _
                  strTempDBName, acTable, !TableName, !TableName
            dbThis.TableDefs.Refresh
            .MoveNext
        Loop
        .Close
    End With
    Set rsStruct = Nothing
    Set dbThis = Nothing
    Set dbTemp = Nothing
    BldTempTables = True

BldTempTables_Exit:
    Exit Function

BldTempTables_Err:
    Select Case Err
        Case Else
            strErrMsg = strErrMsg & "Error #: " & Format$(Err.Number) & vbCrLf
            strErrMsg = strErrMsg & "Error Description: " & Err.Description
            MsgBox strErrMsg, vbInformation, "BldTempTables"
            BldTempTables = False
            Resume BldTempTables_Exit
    End Select
End Function