Creare una tabella con VBA scegliendo il nome tabella

Question

Buona Domenica !

Sto provando ad usare il VBA per creare con un semplice click su una maschera una nuova tabella pre-impostata (poi per i dati da trasferire aprirò altra discussione).

Il codice che sto usando, e che mi da errori, è riportato sotto.  Oltre agli errori, vorrei modificarlo in modo da porte scegliere il nome della tabella ogni volta che voglio.

Come è migliorabile ?

Grazie.

Private Sub Comando2_Click()

    Dim cat As New ADOX.Catalog

    Dim tbl As ADOX.Table

    Dim newdata

    Dim strMsg As String

    Dim Response

    Set cat.ActiveConnection = CurrentProject.Connection

    Set tbl = New ADOX.Table

'Costruisce la stringa per la domanda da visualizzare

'nella finestra di messaggio usando l'argomento intrinseco NewData

    strMsg = "'" & newdata & "' non è un nome di una tabella esistente"

    strMsg = strMsg & vbCrLf & "Desidera aggiungerla all'elenco delle tabelle ?"

    strMsg = strMsg & vbCrLf & "Clic su Sì per aggiungerla oppure su No"

'Presenta l'alternativa all'operatore

    If MsgBox(strMsg, vbQuestion + vbYesNo, _

                "Aggiungere una nuova tabella ?") = vbNo Then

'Se l'operatore rinuncia a modificare l'elenco,

'imposta il valore della costante intrinseca Response

        Response = acDataErrContinue

    Else

        tbl.Name = "MiaTabella"

    End If

    With tbl.Columns

        .Append "MiaTabellaID", adInteger

        .Append "Campo1", adVarWChar, 50

        .Append "Campo2", adVarWChar

        .Append "Campo3", adVarWChar

        With !MiaTabellaID

            Set .ParentCatalog = cat

            .Properties("Autoincrement") = True

        End With

        With !Campo1

            Set .ParentCatalog = cat

            .Properties("Nullable") = False

        End With

    End With

    Set ind = New ADOX.Index

    ind.Name = "PrimaryKey"

    ind.PrimaryKey = True

    ind.Columns.Append "MiaTabellaID"

    tbl.Indexes.Append ind

    Set ind = Nothing

    cat.Tables.Append tbl

    Set tbl = Nothing

    Set cat = Nothing

'Imposta un valore di uscita

'per la costante intrinseca Response

    Response = acDataErrAdded

    Application.RefreshDatabaseWindow

End Sub

Answer 1

ciao Roberto,

Grazie dell'aiuto.

Ho provato il codice DAO, funziona bene.

prego e bene.

[...]

Solo una piccola cosa.

Set tdf = CurrentDb.CreateTableDef(strTableName)

Set fld = tdf.CreateField("CampoProva", dbText)

tdf.Fields.Append fld

in corrispondenza del secondo rigo c'è "CampoProva". Questo campo prova me lo ritrovo anche in tabella.

Ho provato a cancellare il rigo, ma poi il codice non funziona più.

[...]

si scusami hai ragione, mi è rimasto li per prova...

ti posto la routine rivista anche per l'attributo autonumber:

Option Compare Database

Option Explicit

Public Sub CreaTabellaConDAO(ByVal strTableName As String)

    On Error GoTo errorHandler

    Dim tdf As DAO.TableDef

    Set tdf = CurrentDb.CreateTableDef(strTableName)

    With tdf

        .Fields.Append .CreateField("NomeCognome", dbText)

        .Fields.Append .CreateField("Qualifica", dbText)

        .Fields.Append .CreateField("Telefono", dbText)

        .Fields.Append .CreateField("Note", dbMemo)

        .Fields("Note").Required = False

        .Fields.Append .CreateField("id", dbLong)

        .Fields("id").Attributes = dbAutoIncrField

    End With

    CurrentDb.TableDefs.Append tdf

exitErrHandler:

    Application.RefreshDatabaseWindow

    Set tdf = Nothing

    Exit Sub

errorHandler:

    With Err

     Select Case .Number

        Case 3010

             If MsgBox(prompt:="La tabella esiste già. La elimino e la creo di nuovo?", _

                       buttons:=vbYesNo + vbExclamation, _

                       Title:="Attenzione") = vbYes Then

                    CurrentDb.TableDefs.Delete strTableName

                Resume

            End If

        Case Else

            VBA.MsgBox "Errore: " & Err & vbCrLf & Err.Description

    End Select

    Resume exitErrHandler

    End With

End Sub

modifica magari il campo id con un nome maggiormente significativo....

ciao, Sandro.

Answer 2

Grazie per l'aiuto, funziona benissimo.

Alla prossima.

Answer 3

Grazie dell'aiuto.

Ho provato il codice DAO, funziona bene.

Solo una piccola cosa.

Set tdf = CurrentDb.CreateTableDef(strTableName)

Set fld = tdf.CreateField("CampoProva", dbText)

tdf.Fields.Append fld

in corrispondenza del secondo rigo c'è "CampoProva". Questo campo prova me lo ritrovo anche in tabella.

Ho provato a cancellare il rigo, ma poi il codice non funziona più.

Inoltre, ho aggiunto al codice una riga:

.Fields.Append .CreateField("ID", dbLong)

per avere l'ID.  Ma poi per dire al programma che quel campo dev'essere AutoIncrement, qual'è il comando ?

Answer 4

ciao Roberto,

ci sono diverse opzioni per creare una tabella, Ado, Dao, e DDL.

dal codice che posti ho come l'impressione tu abbia fatto un mix con l'evento not in list di una combo a Ado :-).

provo a darti un esempio di quanto sopra indicato.

Crea una maschera con una TextBox la chiami txtTable.

Crea un commanButton lo chiami  cmdCreateTable.

su evento click invochi :

Option Compare Database

Option Explicit

Private Sub cmdCreateTable_Click()

With Me

    If Len(.txtTable & vbNullString) = 0 Then

        VBA.MsgBox prompt:="Nessuna nome di tabella inserito", _

                   buttons:=vbCritical, _

                   title:="Attenzione"

        Exit Sub

    End If

    CreaTabellaConDAO .txtTable   'prova anche le altre due soluzioni

End With

End Sub

CreaTabellaConDAO è una delle sub che inserirai un modulo standard.

Inserisco anche le altre due routine per creare una tabella con Ado e uno statement SQL, ( Data, Definition, Language)

Option Compare Database

Option Explicit

Public Sub CreaTabellaConDDL(ByVal strTableName As String)

On Error GoTo errorHandler

Dim strSql As String

 strSql = "CREATE TABLE [" & strTableName & "](" & _

  "CreationTime2 DATE," & _

  "LastModificationTime DATE," & _

  "SenderName MEMO," & _

  "SenderAddress MEMO," & _

  "SentOn DATE," & _

  "Sent YESNO," & _

  "TO memo," & _

  "CC memo," & _

  "BCC memo," & _

  "UnRead YESNO," & _

  "ReceivedByName MEMO," & _

  "ReceivedOnBehalfOfName MEMO," & _

  "ReceivedTime DATE," & _

  "ConversationTopic MEMO," & _

  "Subject memo," & _

  "Categories MEMO," & _

  "HTMLBody MEMO," & _

  "Size Long," & _

  "fullPath MEMO," & _

  "Attachments MEMO)"

  CurrentDb.Execute strSql, &H80

exitErrHandler:

    Application.RefreshDatabaseWindow

    Exit Sub

errorHandler:

With Err

     Select Case .Number

        Case 3010

           If MsgBox(prompt:="La tabella esiste già. La elimino e la creo di nuovo?", _

                       buttons:=vbYesNo + vbExclamation, _

                       Title:="Attenzione") = vbYes Then

                    CurrentDb.TableDefs.Delete strTableName

                Resume

            End If

        Case Else

            VBA.MsgBox "Errore: " & Err & vbCrLf & Err.Description

    End Select

    Resume exitErrHandler

    End With

End Sub

Public Sub CreaTabellaConAdo(ByVal strTableName As String)

  On Error GoTo errorHandler

    Dim cat As New ADOX.Catalog

    Dim tbl As New ADOX.Table

    cat.ActiveConnection = CurrentProject.Connection

    With tbl

        .Name = strTableName

        .Columns.Append "nome", adVarWChar

        .Columns.Append "cognome", adVarWChar

        .Columns.Append "indirizzo2", adVarWChar

        .Columns.Append "Note", adLongVarWChar

        .Columns("Note").Attributes = adColNullable

    End With

exitErrHandler:

    cat.Tables.Append tbl

    Set cat = Nothing

    Application.RefreshDatabaseWindow

    Exit Sub

errorHandler:

    With Err

     Select Case .Number

        Case -2147217857

           If MsgBox(prompt:="La tabella esiste già. La elimino e la creo di nuovo?", _

                       buttons:=vbYesNo + vbExclamation, _

                       Title:="Attenzione") = vbYes Then

                    cat.Tables.Delete strTableName

                Resume

            End If

        Case Else

            VBA.MsgBox "Errore: " & Err & vbCrLf & Err.Description

    End Select

    Resume exitErrHandler

    End With

End Sub

Public Sub CreaTabellaConDAO(ByVal strTableName As String)

    On Error GoTo errorHandler

    Dim tdf As DAO.TableDef

    Dim fld As DAO.Field

    Set tdf = CurrentDb.CreateTableDef(strTableName)

    Set fld = tdf.CreateField("CampoProva", dbText)

    tdf.Fields.Append fld

    With tdf

        .Fields.Append .CreateField("NomeCognome", dbText)

        .Fields.Append .CreateField("Qualifica", dbText)

        .Fields.Append .CreateField("Telefono", dbText)

        .Fields.Append .CreateField("Note", dbMemo)

        .Fields("Note").Required = False

    End With

    CurrentDb.TableDefs.Append tdf

exitErrHandler:

    Application.RefreshDatabaseWindow

    Exit Sub

errorHandler:

    With Err

     Select Case .Number

        Case 3010

           If MsgBox(prompt:="La tabella esiste già. La elimino e la creo di nuovo?", _

                       buttons:=vbYesNo + vbExclamation, _

                       Title:="Attenzione") = vbYes Then

                    CurrentDb.TableDefs.Delete strTableName

                Resume

            End If

        Case Else

            VBA.MsgBox "Errore: " & Err & vbCrLf & Err.Description

    End Select

    Resume exitErrHandler

    End With

end sub

se lavori con Jet/Ace non scomoderei ado, ma andrei con Dao oppure con la DDL.

HTH.

Ciao, Sandro.