VBA Access - Adicionando campo em tabela pré-existente - VBA Access: How to Add Fields to Existing Tables for BI and Data Automation

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    https://www.linkedin.com/in/andreluizbernardes/

    ' 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    https://www.linkedin.com/in/andreluizbernardes/

    ' 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   https://www.linkedin.com/in/andreluizbernardes/

    ' 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