TKSoft-Online

Sub NewCreateFieldADOX(strTabName As String, strNewFldName As String, _
                       varNewFldTyp As Variant, _
                       Optional intNewFldSize As Integer = 50, _
                       Optional boolNewZeroL As Boolean = False, _
                       Optional strNewDefaultV As String = "", _
                       Optional boolAuto As Boolean = False)
'*******************************************
'Name:      NewCreateField (Sub)
'Purpose:   Erstellt ein neues Feld in der angegebenen Tabelle in der 
'           aktuellen Datenbank mittels ADOX
'Author:    Thomas Keßler
'Date:      Januar 09, 2003, 14:05:15
'Inputs:    TabName = Name der neuen Tabelle, NewFldName = Name des neuen Feldes
'           varNewFldTyp = Typ des neuen Feldes,
'           adDate=7, adDouble=5, adInteger=3, adSingle=4, adBoolean=11, adCurrency=6
'           adVarWChar=202, weitere s. OH "DataTypeEnum;"
'           NewFldSize = Grösse des neuen Feldes (nur Textfelder),
'           NewZeroL=Null Zeichenfolge zulässig
'           NewDefaultV = Standardwert, boolAuto=Autowertfeld nur DatenTyp Integer
'Output:
'*******************************************
On Error GoTo Err_NewField

Dim cn As New ADODB.Connection
Dim cat As New ADOX.Catalog
Dim tbl As ADOX.Table
Dim col As New ADOX.Column

Set cn = CurrentProject.Connection
Set cat.ActiveConnection = cn
Set tbl = cat.Tables(strTabName)
Set col.ParentCatalog = cat

    With col
        .Name = strNewFldName
        .Type = varNewFldTyp
        If varNewFldTyp = 202 Or varNewFldTyp = adVarWChar Then
            If intNewFldSize > 255 Then intNewFldSize = 255
            .DefinedSize = intNewFldSize
        End If
        If boolNewZeroL = True Then .Attributes = adColNullable
        If strNewDefaultV <> "" Then .Properties("Default") = strNewDefaultV
        If boolAuto = True And (varNewFldTyp = 3 Or varNewFldTyp = adInteger) Then
            .Properties("Autoincrement") = True
        End If
        tbl.Columns.Append col
    End With
    
Set cat = Nothing
cn.Close

Err_NewField_Exit:
    Exit Sub
Err_NewField:
    Dim strErrString As String
    strErrString = "Error Information..." & vbCrLf
    strErrString = strErrString & "Error#: " & Err.Number & vbCrLf
    strErrString = strErrString & "Description: " & Err.Description & vbCrLf
    MsgBox strErrString, vbCritical + vbOKOnly, "Error in Sub: NewCreateFieldADOX"
    Resume Err_NewField_Exit
End Sub