'Crea un módulo nuevo y pega este código. Nombre: basPropiedadesBaseDatos

Option Compare Database
Option Explicit


'En este módulo hay 2 funciones, mc_FichaPersonalizar y mc_FichaResumen, y _
6 procedimientos de ejemplo para estas dos funciones. _
En cada una de ellas se explica el funcionamiento y para que se pueden utilizar.

'mc_FichaResumen, _
    Esta función es para establecer, modificar y obtener el valor de las propiedades de la _
    ficha Resumen (SummaryInfo) del cuadro de diálogo Archivo/Propiedades de la BD.
    
'mc_FichaPersonalizar, _
    Esta función es para establecer, modificar y obtener el valor de las propiedades de la _
    ficha Personalizar (UserDefined) del cuadro de diálogo Archivo/Propiedades de la BD.

Private Sub Obtenermc_FichaResumen()
'Procedimiento de ejemplo para conocer, obtener una propiedad de la ficha Resumen.
'Última modificación: 10/10/2001
    
    'Para las funciones que se utilizan, debemos conocer la ruta y nombre de la BD.
    'Conocer la ruta de esta base de datos y de la base de datos principal vinculada.
    Dim dbsActual As Database                   'Declarar como Base Datos.
    Dim strRutaBD As String                       'Para conocer la ruta de la Base de Datos.
    'Establecer a la variable, la ruta y nombre utilizando la función CodeDB.
    Set dbsActual = CodeDb
    'Establece a la variable, la ruta y nombre de la DB.
    strRutaBD = dbsActual.Name

    'Obtener el valor de la propiedad personalizada Web2.
    MsgBox mc_FichaResumen("Title", strRutaBD)
    'En caso de no obtener ningún valor, es por que la propiedad no existe, para crearla _
    utilizar el siguiente procedimiento de prueba Establecermc_FichaPersonalizar
    
End Sub

Private Sub Establecermc_FichaResumen()
'Procedimiento de ejemplo para establecer una propiedad en la ficha Resumen.
'Última modificación: 10/10/2001
    
    'Para las funciones que se utilizan, debemos conocer la ruta y nombre de la BD.
    'Conocer la ruta de esta base de datos y de la base de datos principal vinculada.
    Dim dbsActual As Database                   'Declarar como Base Datos.
    Dim strRutaBD As String                       'Para conocer la ruta de la Base de Datos.
    'Establecer a la variable, la ruta y nombre utilizando la función CodeDB.
    Set dbsActual = CodeDb
    'Establece a la variable, la ruta y nombre de la DB.
    strRutaBD = dbsActual.Name

    'Establecer el valor de la propiedad personalizada Web2.
    MsgBox mc_FichaResumen("Title", strRutaBD, "Título de la BD")
    'En caso de querer borrar la propiedad, utilizar el siguiente procedimiento de _
    prueba Borrarmc_FichaPersonalizar

End Sub

Private Sub Borrarmc_FichaResumen()
'Procedimiento de ejemplo para borrar una propiedad de la ficha Resumen.
'Última modificación: 10/10/2001
    
    'Para las funciones que se utilizan, debemos conocer la ruta y nombre de la BD.
    'Conocer la ruta de esta base de datos y de la base de datos principal vinculada.
    Dim dbsActual As Database                   'Declarar como Base Datos.
    Dim strRutaBD As String                       'Para conocer la ruta de la Base de Datos.
    'Establecer a la variable, la ruta y nombre utilizando la función CodeDB.
    Set dbsActual = CodeDb
    'Establece a la variable, la ruta y nombre de la DB.
    strRutaBD = dbsActual.Name

    'Borrar la propiedad personalizada Web2.
    MsgBox mc_FichaResumen("Title", strRutaBD, Null)

End Sub

Private Sub Obtenermc_FichaPersonalizar()
'Procedimiento de ejemplo para conocer, obtener una propiedad de la ficha Personalizar.
'Última modificación: 10/10/2001
    
    'Para las funciones que se utilizan, debemos conocer la ruta y nombre de la BD.
    'Conocer la ruta de esta base de datos y de la base de datos principal vinculada.
    Dim dbsActual As Database                   'Declarar como Base Datos.
    Dim strRutaBD As String                       'Para conocer la ruta de la Base de Datos.
    'Establecer a la variable, la ruta y nombre utilizando la función CodeDB.
    Set dbsActual = CodeDb
    'Establece a la variable, la ruta y nombre de la DB.
    strRutaBD = dbsActual.Name

    'Obtener el valor de la propiedad personalizada Web2.
    MsgBox mc_FichaPersonalizar("Web2", strRutaBD)
    'En caso de no obtener ningún valor, es por que la propiedad no existe, para crearla _
    utilizar el siguiente procedimiento de prueba Establecermc_FichaPersonalizar
    
End Sub

Private Sub Establecermc_FichaPersonalizar()
'Procedimiento de ejemplo para establecer una propiedad en la ficha Resumen.
'Última modificación: 10/10/2001
    
    'Para las funciones que se utilizan, debemos conocer la ruta y nombre de la BD.
    'Conocer la ruta de esta base de datos y de la base de datos principal vinculada.
    Dim dbsActual As Database                   'Declarar como Base Datos.
    Dim strRutaBD As String                       'Para conocer la ruta de la Base de Datos.
    'Establecer a la variable, la ruta y nombre utilizando la función CodeDB.
    Set dbsActual = CodeDb
    'Establece a la variable, la ruta y nombre de la DB.
    strRutaBD = dbsActual.Name

    'Establecer el valor de la propiedad personalizada Web2.
    MsgBox mc_FichaPersonalizar("Web2", strRutaBD, dbText, "www.iespana.com/McPegasus")
    'En caso de querer borrar la propiedad, utilizar el siguiente procedimiento de _
    prueba Borrarmc_FichaPersonalizar

End Sub

Private Sub Borrarmc_FichaPersonalizar()
'Procedimiento de ejemplo para borrar una propiedad en la ficha Resumen.
'Última modificación: 10/10/2001
    
    'Para las funciones que se utilizan, debemos conocer la ruta y nombre de la BD.
    'Conocer la ruta de esta base de datos y de la base de datos principal vinculada.
    Dim dbsActual As Database                   'Declarar como Base Datos.
    Dim strRutaBD As String                       'Para conocer la ruta de la Base de Datos.
    'Establecer a la variable, la ruta y nombre utilizando la función CodeDB.
    Set dbsActual = CodeDb
    'Establece a la variable, la ruta y nombre de la DB.
    strRutaBD = dbsActual.Name

    'Borrar la propiedad personalizada Web2.
    MsgBox mc_FichaPersonalizar("Web2", strRutaBD, dbText, Null)

End Sub

Public Function mc_FichaResumen(strNombrePropiedad As String, strRutaBD As String, _
                                        Optional vatValorPropiedad) As String
'Última modificación: 10/10/2001

'Esta función es para leer y/o establecer valores a las propiedades de la ficha Resumen _
(SummaryInfo). _
El parámero vatValorPropiedad es opcional, si no se indica, la función obtiene el valor. _
Cuando este parámetro tiene valor, la función entiende que debe de establecer el _
nuevo valor. _
En caso de ser distintos los valores de la propiedad que entra (vatValorPropiedad) con la _
actual (en la ficha Resumen) o no existe, se asignaria a la propiedad de la ficha, el valor _
del parámetro vatValorPropiedad.

'Parámetros, _
        strNombrePropiedad, Nombre de la propiedad a establecer, modificar u obtener. _
                            Pueden ser: _
                                - "Title",          Título. _
                                - "Subject",        Asunto _
                                - "Author",         Autor _
                                - "Manager",        Responsable _
                                - "Company",        Organización _
                                - "Category",       Categoria _
                                - "Keywords",       Palabras Clave _
                                - "Comments",       Comentarios _
                                - "Hyperlink Base", BaseHipervínculo _
 _
        strRutaBD:          Ruta y nombre de la Base de Datos a modificar las propiedades. _
        vatValorPropiedad:  (Opcional) Texto a indicar en la ficha Resumen.

'Notas: _
    Las propiedades de fecha DateCreated y LastUpdated, son solo de lectura. _

    Dim dbs As Database                             'Declarar como Base Datos.
    Dim docSmI As DOCUMENT                          'Declarar como Objeto de Documento.
    Dim cntDbs As Container                         'Declarar como Objeto de Contenedor.
    Dim prpSmI As Property                          'Declarar como Objeto de propiedad.
    
On Error GoTo mc_FichaResumen_Err                   'Inicializa el controlador de error.

    'Comprobar si el parámetro tiene valor.
    If strRutaBD = "" Then
        DoCmd.Beep
        MsgBox "La ruta no está correctamente establecida." _
            , vbCritical + vbOKOnly, "McPegasus informa."
        Exit Function
    End If

    'Establecer las distintas referencias de objetos como variables.
    Set dbs = OpenDatabase(strRutaBD)               'Abrir la Base de Datos.
    Set cntDbs = dbs.Containers!Databases
    'Establecer el objeto docSmi como SummaryInfo (Ficha Resumen)
    Set docSmI = cntDbs.Documents!SummaryInfo
    
    docSmI.Properties.Refresh                       'Actualizar las propiedades.
   
   'En caso de ser cadena vacia ( "" ), convertir a nula. Antes hay que filtrar si se _
    ha pasado, en caso contrario da error.
    If Not IsMissing(vatValorPropiedad) Then
        If vatValorPropiedad = "" Then vatValorPropiedad = Null
    End If
     
    'Comprobar si se ha pasado el parámetro vatValorPropiedad, en este caso es por que se _
    quiere obtener solo el valor de la propiedad pasada en el parámetro strNombrePropiedad.
    If Not IsMissing(vatValorPropiedad) Then                'Si el argumento se ha pasado ...
        'En el caso de que el valor de la propiedad es cadena nula ...
        If IsNull(vatValorPropiedad) Then
            docSmI.Properties.Delete (strNombrePropiedad)   '... se borra la propiedad.
        '... comprobar si se han echo modificaciones ...
        ElseIf vatValorPropiedad <> docSmI.Properties(strNombrePropiedad) Then
            docSmI.Properties.Delete (strNombrePropiedad)   '... borrar la propiedad...
            '... volver a crear la propiedad con el nuevo valor...
            Set prpSmI = docSmI.CreateProperty(strNombrePropiedad, dbText, vatValorPropiedad)
            'Anexar a la colección...
            docSmI.Properties.Append prpSmI
            docSmI.Properties.Refresh
            'Establecer al nombre de la función el valor de la propiedad.
            mc_FichaResumen = docSmI.Properties(strNombrePropiedad)
        Else
            mc_FichaResumen = docSmI.Properties(strNombrePropiedad)
        End If
    Else
        'Comprobar si la propiedad (strNombrePropiedad) existe, para ello se establece el _
        valor de la propiedad al nombre de la función, en caso de error 3270, Propiedad no _
        encontrada, se va al controlador de errores y se crea dicha propiedad, luego se _
        vuelve a la línea y se asigna el nuevo valor. _
        En caso de Propiedad encontrada, continua sin error.
        mc_FichaResumen = docSmI.Properties(strNombrePropiedad)
    End If

mc_FichaResumen_salir:
    Exit Function

mc_FichaResumen_Err:
    Select Case Err.Number
        Case 3265               'No se encontró el elemento de esta colección.
            Resume Next
        Case 3270                               'Propiedad no encontrada.
            'Si el argumento se ha pasado ...
            If Not IsMissing(vatValorPropiedad) Then
                '... en caso de no encontrar la propiedad, crearla...
                Set prpSmI = docSmI.CreateProperty(strNombrePropiedad, dbText, vatValorPropiedad)
                '... Anexar a la colección...
                docSmI.Properties.Append prpSmI
                'Establecer al nombre de la función el valor de la propiedad.
                mc_FichaResumen = docSmI.Properties(strNombrePropiedad)
            End If
            Resume mc_FichaResumen_salir        'Salir de la función
        Case Else                               'Cazar todos aquellos errores inesperados.
            MsgBox Err.Number & " " & Err.Description
            mc_FichaResumen = ""                'Establece cadena vacia
            Resume mc_FichaResumen_salir        'Salir de la función
    End Select

End Function

Function mc_FichaPersonalizar(strNombrePropiedad As String, strRutaBD As String, _
            Optional entTipoPropiedad As Variant, Optional vatValorPropiedad) _
            As String
'Última modificación: 10/10/2001

'Esta función es para establecer valores a las propiedades de la ficha Personalizar _
(UserDefined). _
En caso de ser distintos los valores de la propiedad que entra (vatValorPropiedad) con la _
actual (en la ficha Personalizar) o no existe, se asignaria a la propiedad el valor del _
parámetro vatValorPropiedad.

'Parámetros, _
        strNombrePropiedad: Nombre de la propiedad a establecer o modificar. _
        entTipoPropiedad:   Define el valor de las constantes que define los tipos de datos _
                            del metodo CreateProperty. _
                            Pueden ser:     Valor de la constante _
                                dbBoolean        1 _
                                dbDate           8 _
                                dbLong           4 _
                                dbText          10 _
 _
        vatValorPropiedad:  Texto a indicar en la ficha Resumen. _
        strRutaBD:          Ruta y nombre de la Base de Datos a modificar las propiedades.

    Dim dbs As Database                             'Declarar como Base Datos.
    Dim docUrD As DOCUMENT                          'Declarar como Objeto de Documento.
    Dim cntDbs As Container                         'Declarar como Objeto de Contenedor.
    Dim prpUrD As Property                          'Declarar como Objeto de propiedad.

On Error GoTo mc_FichaPersonalizar_Err              'Inicializa el controlador de error.

    'Establecer las distintas referencias de objetos como variables.
    Set dbs = OpenDatabase(strRutaBD)               'Abrir la Base de Datos.
    Set cntDbs = dbs.Containers!Databases
    'Establecer el objeto docUrD como UserDefined (Ficha Personalizar)
    Set docUrD = cntDbs.Documents!UserDefined
    
    docUrD.Properties.Refresh                       'Actualizar las propiedades.
    
    'En caso de ser cadena vacia ( "" ), convertir a nula. Antes hay que filtrar si se _
    ha pasado, en caso contrario da error.
    If Not IsMissing(vatValorPropiedad) Then
        If vatValorPropiedad = "" Then vatValorPropiedad = Null
    End If
    
    'Comprobar si se ha pasado el parámetro vatValorPropiedad, en este caso es por que se _
    quiere obtener solo el valor de la propiedad pasada en el parámetro strNombrePropiedad.
    If Not IsMissing(vatValorPropiedad) Then                'Si el argumento se ha pasado ...
        'En el caso de que el valor de la propiedad es cadena nula ...
        If IsNull(vatValorPropiedad) Then
            docUrD.Properties.Delete (strNombrePropiedad)   '... se borra la propiedad.
       '... comprobar si se han echo modificaciones ...
        ElseIf vatValorPropiedad <> docUrD.Properties(strNombrePropiedad) Then
            docUrD.Properties.Delete (strNombrePropiedad)   '... borrar la propiedad...
            '... para volver a crear la propiedad con el nuevo valor...
            Set prpUrD = docUrD.Properties(strNombrePropiedad)
            'Establecer el valor de la propiedad personalizada.
            prpUrD = vatValorPropiedad
            'Establecer al nombre de la función el valor de la propiedad.
            mc_FichaPersonalizar = docUrD.Properties(strNombrePropiedad)
        Else
            'Establecer al nombre de la función el valor de la propiedad.
            mc_FichaPersonalizar = docUrD.Properties(strNombrePropiedad)
        End If
    Else
        'Comprobar si la propiedad (strNombrePropiedad) existe, para ello se establece el _
        valor de la propiedad al nombre de la función, en caso de error 3270, Propiedad no _
        encontrada, se va al controlador de errores y se crea dicha propiedad. _
        En caso de Propiedad encontrada, continua sin error.
        mc_FichaPersonalizar = docUrD.Properties(strNombrePropiedad)
    End If

mc_FichaPersonalizar_salir:
    Exit Function

mc_FichaPersonalizar_Err:
    Select Case Err.Number
        Case 3265               'No se encontró el elemento de esta colección.
            Resume Next
        Case 3270               'Propiedad no encontrada.
            'Si el argumento se ha pasado ...
            If Not IsMissing(vatValorPropiedad) Then
                '... en caso de no encontrar la propiedad, crearla...
                Set prpUrD = docUrD.CreateProperty(strNombrePropiedad, entTipoPropiedad, vatValorPropiedad)
                '... Anexar a la colección...
                docUrD.Properties.Append prpUrD
                Resume Next     'Volver a la línea siguiente de donde se produjo el error.
            End If
        Case Else               'Cazar todos aquellos errores inesperados.
            MsgBox Err.Number & " " & Err.Description
            mc_FichaPersonalizar = ""
            Resume mc_FichaPersonalizar_salir
    End Select
    
End Function