'Modulo RELEASE
'Autore: Enrico Oemi
'Le funzioni sono state estratte da un programma e adattate per
'essere utilizzate in un contesto più generale. Verificate...
'_________________________________________________
' Le funzioni sono:
'  REL_ApriBE --> Apre il database BE.
'  REL_Chiudi --> Chiude il database BE.
'  AggiungiCampo --> Aggiunge un campo ad una tabella del database BE aperto.
'  CreaTabella --> Crea nuova tabella in database BE.
'  CreaIndice --> Crea un nuovo indice su campo di tabella di database BE.
'  AggiornaVersione --> Scrive sulla barra del titolo il testo che si vuole.
'  LeggiVer --> Legge il testo sulla barra del titolo.

' Le ultime due funzioni possono essere utilizzate per tenere sincronizzate
' le versioni di FE e BE. Controllando la versione si
' capisce se il BE ha tutti i campi che FE cercherà di utilizzare.

Option Explicit
Dim MiaAreaLavoro As DAO.Workspace, dbs As DAO.Database, DbsP As DAO.Database

Function REL_ApriBE(nomeBE As String)
    Set MiaAreaLavoro = DBEngine.Workspaces(0)
    Set DbsP = DBEngine.Workspaces(0).Databases(0)
    Set dbs = MiaAreaLavoro.OpenDatabase(nomeBE)
End Function

Function REL_Chiudi()
    Set dbs = Nothing
End Function

Function aggiungiCampo(tabella As String, campo As String, tipo As Integer, _
    Optional dimensioni As Long, Optional incrementa As Boolean = False, _
    Optional default As Variant, Optional descr As String) As Boolean

    Dim tdef As DAO.TableDef, fld As DAO.Field
    Dim prp As DAO.Property
    Set tdef = dbs.TableDefs(tabella)
    Set fld = tdef.CreateField(campo, tipo, dimensioni)
    If fld.Type = dbLong And incrementa = True Then fld.Attributes = dbAutoIncrField
    If Not IsNull(dimensioni) Then fld.Size = dimensioni
    If Not IsMissing(default) Then fld.DefaultValue = default
    On Error Resume Next
    tdef.Fields.Append fld
    If Not IsMissing(descr) Then
        Set prp = fld.CreateProperty("description", dbText)
        prp.Value = descr
        fld.Properties.Append prp
    End If
    If Err Then
        aggiungiCampo = False
    Else
        aggiungiCampo = True
    End If
End Function

Function creaTabella(tabella As String) As Boolean
    Dim tdf As DAO.TableDef, fld, fldindice As DAO.Field
    Dim idx As DAO.Index
    Set tdf = dbs.CreateTableDef(tabella)
    Set fld = tdf.CreateField("ID" & tabella, dbLong)
    fld.Attributes = fld.Attributes + dbAutoIncrField
On Error Resume Next
    ' Accoda i campi.
    tdf.Fields.Append fld
    ' Crea indice chiave primaria.
    Set idx = tdf.CreateIndex("ChiavePrimaria")
    Set fldindice = idx.CreateField("ID" & tabella, dbLong)
    ' Accoda i campi indice.
    idx.Fields.Append fldindice
    ' Imposta la proprietà Primary.
    idx.Primary = True
    ' Accoda indice.
    tdf.Indexes.Append idx
    ' Accoda oggetto TableDef.
    dbs.TableDefs.Append tdf
    dbs.TableDefs.Refresh
    If Err Then
        creaTabella = False
    Else
        creaTabella = True
    End If
End Function

Function creaIndice(tabella As String, indice As String, Campo1 As String, _
    Optional Campo2 As String, Optional Campo3 As String, Optional Campo4 As String, _
    Optional campo5 As String) As Boolean

    Dim tdf As DAO.TableDef, idx As DAO.Index
    Set tdf = dbs.TableDefs(tabella)
    With tdf
        Set idx = .CreateIndex(indice)
        With idx
            .Fields.Append .CreateField(Campo1)
            If Campo2 <> "" Then .Fields.Append .CreateField(Campo2)
            If Campo3 <> "" Then .Fields.Append .CreateField(Campo3)
            If Campo4 <> "" Then .Fields.Append .CreateField(Campo4)
            If campo5 <> "" Then .Fields.Append .CreateField(campo5)
            .IgnoreNulls = True
        End With
        On Error Resume Next
        .Indexes.Append idx
        .Indexes.Refresh
        On Error GoTo 0
    End With
    If Err Then
        creaIndice = False
    Else
        creaIndice = True
    End If
End Function

Function aggiornaversione(ver As String) As Boolean
    Dim apptitle As DAO.Property
    On Error Resume Next
    Set apptitle = dbs.CreateProperty("AppTitle", dbText)
    apptitle.Value = ver
    dbs.Properties.Append apptitle
    dbs.Properties("apptitle") = ver
    On Error GoTo 0
End Function

Function leggiVer() As String
    On Error Resume Next
    If Not IsNull(dbs.Properties("apptitle")) Then leggiVer = CStr(dbs.Properties("apptitle"))
    On Error GoTo 0
End Function