Option Compare Database
Option Explicit
'***************************************************************
'        (C) Francisco García Aguado, Junio de 2002            *
'                        Utiliza DAO                           *
'Este módulo es exclusivo para Modificar Tablas del módulo de  *
'Servicio con la incorporaciónde nuevos campos.                *
'***************************************************************

Function CrearNuevoCampo(Ruta As String, NombreTabla As String, NombreCampo As String, TipoCampo As Integer, NombreIndice As String, TipoIndice As Boolean)
 On Error GoTo Err_Comando0_Click
'Esta función añade campos a las tablas ya existentes de base de datos de Servicio

'Recibe como parametros:
'Ruta: Ruta y nombre completo de la MDB de servicio a tratar
'NombreTabla: Tabla a modificar
'NombreCampo: Nombre del campo a añadir
'NombreIndice: Nombre del indice, si el campo está indexado
'TipoIndice: Si está con o sin duplicados.
'TipoCampo: Tipo del campo, según las constantes de Access.
' A Y U D A  D E  C O N S T A N T E S  T I P O / C A M P O === I N T E G E R
'dbBinary=9
'dbBoolean=1
'dbByte =2
'dbChar =18
'dbCurrency=5
'dbDate Date / Time=8
'dbDecimal Decimal=20
'dbDouble Double=7
'dbFloat Float=21
'dbInteger Integer=3
'dbLong Long=4
'dbLongBinary Long Binary (Objeto OLE)=11
'dbMemo Memo=12
'dbNumeric Numeric19
'dbSingle Single=6
'dbText Text=10
'dbTime Time=22

 Dim Base As Database
 Dim tdfTabla As TableDef
 Dim fldCampo As Field
 Dim NewIdx As Index
 
 ' abro la base de servicio donde tenga los datos
 Set Base = OpenDatabase(Ruta)
 
 
 ' abro el objeto Tabla al cual voy  añadir campos
 Set tdfTabla = Base(NombreTabla)
 ' evito una doble actualización:
 For Each fldCampo In Base.TableDefs(NombreTabla).Fields
  If UCase(fldCampo.Name) = UCase(NombreCampo) Then
   MsgBox "La tabla de datos " & tdfTabla.Name & " ya está actualizada en el campo: " & UCase(fldCampo.Name), vbInformation + vbOKOnly, "Tabla ya actualizada."
   Exit Function
  End If
 Next
 
 ' Creo y agrego el objeto Campo nuevo
 
 With tdfTabla
      .Fields.Append .CreateField(NombreCampo, TipoCampo)
      
 End With
 
 ' Creo y agrego los indices, si es que se pasan como parametros NO NULOS
 ' para lo cual, lo compruebo viendo si se ha recibido el parametro como ""
 If Len(NombreIndice) <> 0 Then
  Set NewIdx = tdfTabla.CreateIndex(NombreIndice)
  NewIdx.Unique = TipoIndice
  Set fldCampo = NewIdx.CreateField(NombreCampo)
  NewIdx.Fields.Append fldCampo
  tdfTabla.Indexes.Append NewIdx
 End If
 Base.Close
 Set Base = Nothing ' libero

Exit_Comando0_Click:
    Exit Function

Err_Comando0_Click:
    ' Ojo  si hay algún usuario
    ' conectado a la base de servicio,el propio sistema de detección de errores
    ' avisa de esta contigencia en esta actualización, con mensaje personalizado.
    If Err.Number = 3262 Then
     MsgBox "No se puede actualizar la tabla pues está en uso en algún " & Chr(13) & _
            "puesto de trabajo. Cierre todas las aplicaciones." _
            , vbCritical + vbOKOnly, "A V I S O  A C T U A L I Z A C I O N"
     
    
     Resume Exit_Comando0_Click
     Exit Function
    End If
      
    MsgBox Err.Description
    Resume Exit_Comando0_Click
End Function

    Source: geocities.com/es/ensolva/Descargas/Documentos

               ( geocities.com/es/ensolva/Descargas)                   ( geocities.com/es/ensolva)                   ( geocities.com/es)