VBA Access - Adicionando campo em tabela pré-existente

Termo de Responsabilidade

Inserir campos em tabelas que já existem são necessidades freqüentes quando efetuamos manutenções em bancos de dados. Mas qual é o código mais apropriado para isso? Segue:

Function Vai()

    ' Author:                     Date:               Contact:

    ' André Bernardes             06/03/2012 16:32    bernardess@gmail.com     https://sites.google.com/site/bernardescvcurriculumvitae/

    ' Application: MedicalPanelAnalyseBrazil®

    ' Source Code:

    ' Listening:

    ' Cria campo dentro de uma tabela.

    

    Call AddFieldToTable ("PMedico", "TimeStamp", dbDate, , , Now())

End Function

Function AddFieldToTable (ByVal TblName As String, FldName As String, FldType As Integer, Optional FldPos As Integer,Optional FldSize, Optional DefaultValue, Optional FldDes, Optional IsAutoNumber) As Boolean

    ' Author:                     Date:               Contact:

    ' André Bernardes             06/03/2012 16:32    bernardess@gmail.com     https://sites.google.com/site/bernardescvcurriculumvitae/

    ' Application: MedicalPanelAnalyseBrazil®

    ' Source Code:

    ' Listening:

    ' Cria campo dentro de uma tabela.

    

    Dim Db As Database

    Dim DbPath As Variant

    Dim Td As TableDef

    Dim Fd As Field

    Dim p As Property

    On Error Resume Next

    'get back end path of linked table

    DbPath = DLookup("Database", "MSysObjects", "Name='" & TblName & "' And Type=6")

    If IsNull(DbPath) Then

        Set Db = CurrentDb 'if local table

    Else

        Set Db = OpenDatabase(DbPath) 'if linked table

        If Err <> 0 Then

            'failed to open back end database

            Exit Function

        End If

        'in case back end has different table name than front end

        TblName = DLookup("ForeignName", "MSysObjects", "Name='" & TblName & "' And Type=6")

    End If

    'get table

    Set Td = Db.TableDefs(TblName)

    If Err <> 0 Then

        'failed to get table

        GoTo Done

    End If

    'if IsAutoNumber, then use the correct field Type

    If Not IsMissing(IsAutoNumber) Then

        If IsAutoNumber Then

            FldType = dbLong

        End If

    End If

    'add field and properties

    With Td

        'create field

        If FldType = dbText And Not IsMissing(FldSize) Then

            Set Fd = .CreateField(FldName, FldType, FldSize)

        Else

            Set Fd = .CreateField(FldName, FldType)

        End If

        

        'position (0 is first position)

        If Not IsMissing(FldPos) Then

            Dim Num As Integer

            For Num = 0 To FldPos - 1

                Td.Fields(Num).OrdinalPosition = Num

            Next

            For Num = FldPos To .Fields.Count - 1

                Td.Fields(Num).OrdinalPosition = Num + 1

            Next

        End If

        

        'if IsAutoNumber

        If Not IsMissing(IsAutoNumber) Then

            If IsAutoNumber Then

                Fd.Attributes = 17

            End If

        End If

        

        'add field to table

        .Fields.Append Fd

        If Err <> 0 Then

            'failed to add field - probably already exists

            GoTo Done

        End If

        

        'default

        If Not IsMissing(DefaultValue) Then

            .Fields(FldName).DefaultValue = DefaultValue

        End If

        

        'add description property

        If Not IsMissing(FldDes) Then

             Set p = .Fields(FldName).CreateProperty("Description", dbText, FldDes)

             .Fields(FldName).Properties.Append p

        End If

        

        'other properties according to personal preference

        If FldType = dbText Then

            .Fields(FldName).AllowZeroLength = True

        End If

        

        

    End With

    AddFieldToTable = True 'defaults to false if it fails to get here

    

'clean up

Done:

    Set Fd = Nothing

    Set Td = Nothing

    If Not Db Is Nothing Then Db.Close

    Set Db = Nothing

End Function

Sub CallAddField()

    ' Author:                     Date:               Contact:

    ' André Bernardes             06/03/2012 16:32    bernardess@gmail.com     https://sites.google.com/site/bernardescvcurriculumvitae/

    ' Application: MedicalPanelAnalyseBrazil®

    ' Source Code:

    ' Listening:

    ' Cria campo dentro de uma tabela.

    

    Dim Result As Boolean

    'sample call:

    Result = AddFieldToTable("Table1", "NewFieldName", dbText, 2, 10, , "sample description")

    Debug.Print Result

    'Possible values for FldType parameter:

    ' dbBigInt (Decimal)

    ' dbBinary

    ' dbBoolean (Yes/No)

    ' dbByte

    ' dbCurrency

    ' dbDate

    ' dbDouble

    ' dbGUID (Replication ID)

    ' dbInteger

    ' dbLong (Long Integer)

    ' dbLongBinary (OLE Object)

    ' dbMemo

    ' dbSingle

    ' dbText (specify size, or length of text)

    ' dbVarBinary (OLE Object)

    'FldPos parameter is the ordinal position, 0 being position 1,

    '  but it works sporadically - I don't know why.

    'For optional IsAutoNumber parameter, use True or False, or leave blank.

End Sub

References:

Tags: VBA, Access, Add, field, table, campo, tabela