CREARE UN DATABASE ACCESS DA CODICE 

Prima di cominciare dobbiamo aggiungere una dll al progetto. 

Quindi fare click su Project >> References

Si aprirà una finestra e spuntare Microsoft DAO 3.6 Object Library (dao360.dll) e poi fare click su Ok

Ora siamo pronti a creare un Database Access da codice Visual Basic 6 (VB6)

' By Davide1986 Code www.imaginsystems.it
' Aggiungere Riferimento Microsoft DAO 3.6 Object Library
Const NameDatabase = "Rubrica" ' Scegliere il nome del Database da creare
Const NameTabella = "TBUser" ' Segli il nome della Tabella da inserire
Const MaxCampi = 2 'non modificare indice che serve ad indicare 0= nome del campo 1=intero tipo del campo se dbText=10 o dbInteger=3 ecc..
Const MaxRecord = 2

Private Function CreaDatabase(ByVal NomeDatabase As String) As Boolean
'Verifico che il NomeDatabase sia corretto senza simboli strani e che non sia vuoto
If Corretto(NomeDatabase) = True And Esiste = Dir(App.Path & "\" & NomeDatabase & ".mdb") Then
NomeDatabase = ClearString(NomeDatabase)

Dim db As DAO.Database
Set db = CreateDatabase(App.Path & "\" & NomeDatabase & ".mdb", dbLangGeneral)

CreaDatabase = True
Else
'Restituisce errore, database non creato
CreaDatabase = False

End If
End Function

Private Function CreaTabella(ByVal NomeTabella As String, ByRef campi() As String, ByVal MaxCampiTabella As Integer) As Boolean
'Verifico che NomeTabella non sia vuoto e che non contiene caratteri strani
CreaTabella = False 'variabile di controllo eseguzione
If Corretto(NomeTabella) = True Then
NomeTabella = ClearString(NomeTabella)

Dim dbs As Database
Dim tdfMiaTabella As TableDef
Dim fldMioCampo As Field

Set dbs = OpenDatabase(App.Path & "\" & NameDatabase & ".mdb")
Set tdfMiaTabella = dbs.CreateTableDef(NomeTabella)

'Se volessi inserire solo un campo nella tabella
'Set fldMioCampo = tdfMiaTabella.CreateField("ImportoOre", dbInteger)
'Inserire il campo nella tabella
'tdfMiaTabella.Fields.Append fldMioCampo

'se vogliamo inserire più campi nella tabella
'With tdfMiaTabella
' .Fields.Append .CreateField(campi(0, 0), campi(0, 1))
' .Fields.Append .CreateField(campi(1, 0), campi(1, 1))
' .Fields.Append .CreateField(campi(2, 0), campi(2, 1))
'End With

'avendo un Array lo controlliamo tutto e inseriamo i dati
For i = 0 To MaxCampiTabella
With tdfMiaTabella
.Fields.Append .CreateField(campi(i, 0), campi(i, 1))
End With
Next

dbs.TableDefs.Append tdfMiaTabella
dbs.Close

CreaTabella = True
End If

End Function
Private Function Corretto(ByVal s As String) As Boolean
Corretto = False
'controllo se è vuto
If s <> "" Then
'pulisco la stringa da caratteri indisiderati
s = ClearString(s)
If s <> "" Then
Corretto = True
Debug.Print "Corretta Stringa = " & s
End If
End If
End Function
Private Function ClearString(ByVal strIn As String) As String

Dim ch As Variant
For Each ch In Array(",", "%", "/", "'", ".", "(", ")", ";", "!", "+", "^", "&", "\", "?", "]", "[", "{", "}", "=", "|", ":", "_")
strIn = Replace(strIn, ch, "")
Next ch
ClearString = Trim$(strIn)

End Function
Private Function AvvioDatabase()

If CreaDatabase(NameDatabase) = True Then

'MsgBox "Creato con sucesso"
Debug.Print "Creato database con sucesso"

Dim ArrayCampi() As String
Dim MaxArrayCampi As Integer

Dim ArrayRecordTest() As String
Dim MaxRecordTest As Integer

ArrayRecordTest = CaricaArrayRecord_Test(4) 'Carica X record di dimostrazione
MaxRecordTest = UBound(ArrayRecordTest) 'Indice Massimo Array , dice quante righe ci sono nell'array

ArrayCampi = CaricaArrayCampi_TBUser() 'Richiama la Funzione e carica tutti i campi
MaxArrayCampi = UBound(ArrayCampi) 'Indice Massimo Array , dice quante righe ci sono nell'array


If CreaTabella(NameTabella, ArrayCampi, MaxArrayCampi) = True Then
'creata la tabella

If AggiungiRecord(NameTabella, ArrayRecordTest, MaxRecordTest) = True Then

End If
End If

Else
'MsgBox "Errore database"
Debug.Print "Errore creazione database"
End If
End Function
Private Function CaricaArrayCampi_TBUser() As String()
Dim Arrays(0 To MaxRecord, 0 To MaxCampi) As String

Arrays(0, 0) = "IDUser"
Arrays(0, 1) = "3" ' dbInteger = 3
Arrays(1, 0) = "Username"
Arrays(1, 1) = "10" 'dbText = 10
Arrays(2, 0) = "Password"
Arrays(2, 1) = "10" 'dbText = 10

CaricaArrayCampi_TBUser = Arrays
End Function
Private Function CaricaArrayRecord_Test(ByRef MaxRecordArray As Integer) As String()
ReDim Arrays(0 To MaxRecordArray, 0 To MaxCampi) As String

Arrays(0, 0) = "Test"
Arrays(0, 1) = "Test"
Arrays(1, 0) = "Demo"
Arrays(1, 1) = "Demo"
Arrays(2, 0) = "Davide"
Arrays(2, 1) = "Davide"
Arrays(3, 0) = "Marco"
Arrays(3, 1) = "Marco"


CaricaArrayRecord_Test = Arrays
End Function
Private Sub Form_Load()
Call AvvioDatabase
End Sub

Private Function AggiungiRecord(ByVal NomeTabella As String, ByRef ArrayRecord() As String, ByVal MaxArrayRecord As Integer) As Boolean
AggiungiRecord = False


'Funzione che serve per aggiungere record a una tabella
Dim dbs As DAO.Database
Dim rst As DAO.Recordset

Set dbs = OpenDatabase(App.Path & "\" & NameDatabase & ".mdb")

Dim query As String
Dim ID_Record As Integer


Set rst = dbs.OpenRecordset("SELECT COUNT(*) AS numero FROM " & NomeTabella)

ID_Record = rst("numero") + 1

For i = 0 To MaxArrayRecord - 1

' SQL INSERT azzione query.
query = "INSERT INTO " & NomeTabella & " VALUES ( "
query = query & "'" & ID_Record & "', "
query = query & "'" & ArrayRecord(i, 0) & "', "
query = query & "'" & ArrayRecord(i, 1) & "' "
query = query & ")"

' Execute the query.
On Error GoTo NotInserted
dbs.Execute (query)

'MsgBox "Ok"
Debug.Print "Eseguita correttamente la funzione inserimento Query = " & query
AggiungiRecord = True
ID_Record = ID_Record + 1
Next
Exit Function
NotInserted:
MsgBox "Error" & Str$(Err.Number) & _
" inserting record." & vbCrLf & _
Err.Description


End Function

Codice Zippato Download File VB6 - ACCESS