Access VBA – Neue Felder per VBA anlegen

Problem

Sie möchten per VBA ein Feld neu anlegen, d.h. Sie wollen bzw. können nicht in die Entwurfsansicht einer Tabelle gehen, da sich die Tabelle „außer Reichweite“ beim Kunden befindet?

Lösung

Nutzen Sie die CreateField Methode

Function NeuesFeld()

On Error Resume Next

 'dbBigInt Big Integer-Daten (nur ODBCDirect)

 'dbBinary Binärdaten

 'dbBoolean Boolesche Daten (True/False)

 'dbByte Byte-Daten (8-Bit)

 'dbChar Zeichensatzdaten (nur ODBCDirect)

 'dbCurrency Währungsdaten

 'dbDate Datumswerte

 'dbDecimal Dezimaldaten (nur ODBCDirect)

 'dbDouble Fließkommadaten mit doppelter Genauigkeit

 'dbFloat Fließkommadaten (nur ODBCDirect)

 'dbGUID Guid - Daten

 'dbInteger Integer-Daten

 'dbLong Long Integer-Daten

 'dbLongBinary Binärdaten(Bitmap)

 'dbMemo Memo-Daten (erweiterter Text)

 'dbNumeric Numerische Daten (nur ODBCDirect)

 'dbSingle Fließkommadaten mit einfacher Genauigkeit

 'dbText Textdaten (variable Länge)

 'dbTime Daten im Zeitformat (nur ODBCDirect)

 'dbTimeStamp Daten in Zeit- und Datumsformat (nur ODBCDirect)

 'dbVarBinary Variable Binärdaten (nur ODBCDirect)

 Dim wsp As Workspace

 Dim db As Database

 Dim vTabelle As TableDef, fld1 As Field ' Verweis auf aktuelle Datenbank holen.

 Set wsp = DBEngine.Workspaces(0)

 Set db = wsp.OpenDatabase(DATENMDB) ' Erstellen einer neuen Tabelle mit zwei Feldern.

 Set vTabelle = db.TableDefs!TBAUFTRAEGE

 Set fld1 = vTabelle.CreateField("ATMITTELBINDUNG", dbText, 255)

 Call SetFieldProperty("TBAUFTRAEGE", "ATMITTELBINDUNG", "Description", "TBAUFTRAEGE - ATMITTELBINDUNG")

 Call SetFieldProperty("TBAUFTRAEGE", "ATMITTELBINDUNG", "Caption", "MIttelbindungsnummer")

 ' Felder anfügen.

 vTabelle.Fields.Append fld1

 MsgBox "Die neuen Felder wurde erfolgreich angelegt", , MSGBOXTITEL

 End Function

 Public Function SetFieldProperty(TblName, FldName, Optional PrpName, Optional PrpVal, Optional PrpType)

 On Error Resume Next

 Dim db As Database, Tbl As DAO.TableDef, Fld As DAO.Field, Prp As DAO.Property

 'Aufruf der Funktion zum Setzten einer Eigenschaft : SetFieldProperty "MeineTabelle","MeinFeld","Format","Currency"

 'Aufruf der Funktion zum Löschen einer Eigenschaft :SetFieldProperty "MeineTabelle","Feld1","Description",""

 Set db = CurrentDb

 Set Tbl = db.TableDefs(TblName)

 Set Fld = Tbl.Fields(FldName)

 On Error Resume Next

 If PrpVal = "" Then ' remove property

 Fld.Properties.Delete PrpName

 Else

 Fld.Properties(PrpName) = PrpVal

 If err.Number = 3270 Then ' property not yet defined

 On Error GoTo 0

 Set Prp = Fld.CreateProperty(PrpName, PrpType, PrpVal)

 Fld.Properties.Append Prp

 Else

 MsgBox err.Description

 End If

 End If

 End Function