|
Option Explicit
Private Sub cmdCreateDB_Click()
Dim strPWD As String
Dim strAppPath As String
Dim strDBFileName As String
Dim WS As Workspace
Dim DB As Database
Dim tdfNew1 As TableDef, tdfNew2 As TableDef
Dim idxNew As Index
Dim relNew As Relation
If chkPWD.Value <> 0 Then
strPWD = txtPWD.Text
If Len(strPWD) = 0 Then
MsgBox "Bitte geben Sie ein Passwort ein!", _
vbOKOnly + vbInformation, Me.Caption
txtPWD.SetFocus
Exit Sub
End If
End If
If Len(txtDBName.Text) <> 0 Then
strAppPath = App.Path
If Right$(strAppPath, 1) <> "\" Then
strAppPath = strAppPath & "\"
End If
strDBFileName = strAppPath & txtDBName.Text
If LCase$(Right$(strDBFileName, 4)) <> ".mdb" Then
strDBFileName = strDBFileName & ".mdb"
End If
On Error GoTo err_Handler
Set WS = DBEngine.Workspaces(0)
If chkPWD.Value = 0 Then
Set DB = WS.CreateDatabase(strDBFileName, dbLangGeneral, _
dbEncrypt)
Else
Set DB = WS.CreateDatabase(strDBFileName, dbLangGeneral & _
";pwd=" & strPWD, dbEncrypt)
End If
Set tdfNew1 = DB.CreateTableDef("tbl_Adressen")
With tdfNew1
.Fields.Append .CreateField("ID", dbLong)
.Fields(0).Attributes = dbAutoIncrField
.Fields.Append .CreateField("Name", dbText, 50)
.Fields.Append .CreateField("Vorname", dbText, 50)
.Fields.Append .CreateField("Strasse", dbText, 50)
.Fields.Append .CreateField("Ort", dbText, 50)
.Fields.Append .CreateField("Telefon", dbText, 20)
.Fields(5).AllowZeroLength = True
.Fields.Append .CreateField("GebDatum", dbText, 10)
.Fields(6).AllowZeroLength = True
Set idxNew = .CreateIndex("IDIndex")
idxNew.Fields.Append idxNew.CreateField("ID")
idxNew.Primary = True
.Indexes.Append idxNew
End With
DB.TableDefs.Append tdfNew1
Set tdfNew2 = DB.CreateTableDef("tbl_Schulden")
With tdfNew2
.Fields.Append .CreateField("ID", dbLong)
.Fields.Append .CreateField("Datum", dbDate)
.Fields.Append .CreateField("Gesamtschulden", dbDouble)
.Fields.Append .CreateField("Einzelbetrag", dbDouble)
.Fields.Append .CreateField("Bemerkungen", dbText, 50)
.Fields(4).AllowZeroLength = True
End With
DB.TableDefs.Append tdfNew2
Set relNew = DB.CreateRelation( _
"ID_Relation", tdfNew1.Name, tdfNew2.Name, _
dbRelationUpdateCascade + dbRelationDeleteCascade)
relNew.Fields.Append relNew.CreateField("ID")
relNew.Fields!ID.ForeignName = "ID"
DB.Relations.Append relNew
DB.Close
WS.Close
Else
MsgBox "Bitte geben Sie einen Datenbanknamen ein", _
vbCritical, "Fehler"
End If
Exit Sub
err_Handler:
Select Case Err.Number
Case 3204
MsgBox "Der Datenbankname ist schon vorhanden!", _
vbExclamation, "Fehler"
Case Else
MsgBox "Es ist der Fehler:" & Str$(Err.Number) & vbCrLf & _
"""quot; & Err.Description & """aufgetreten.", _
vbCritical, "Fehler"
End Select
Exit Sub
End Sub
|
|