'-------------------------------------------------------------------------
' Subroutine che estrae tutte e sole le proprietà Custom di un oggetto
' DAO, passato tramite il parametro obj, restituendole nel parametro
' customProperties di tipo Collection.
' Se si desidera anche ottenere in customProperties e preservare in
' obj.Properties l'ordine originario delle proprietà Custom, è sufficiente
' invocare 2 volte di seguito la subroutine con gli stessi parametri,
' resettando il parametro customProperties tra le 2 chiamate (altrimenti
' ad ogni invocazione l'ordine (soltanto) delle proprietà Custom
' viene invertito):
'
' extractCustomProperties myObj , myCustomProperties
' set myCustomProperties = Nothing
' extractCustomProperties myObj , myCustomProperties
'
' Autore: Emanuele Zeppieri - 1999
'-------------------------------------------------------------------------
Sub extractCustomProperties(obj As Object, customProperties As Collection)
    Dim prp As Property
    Dim i As Integer
    Dim prpName As String, prpType As Integer, prpValue As Variant

'-------------------------------------------------------------------------
' Intercetta l'errore causato dal tentativo di rimozione di una
' proprietà NON Custom dall'insieme Properties.
'-------------------------------------------------------------------------
On Error GoTo doExit

    '------------------------------------------------------------------------
    ' Ciclo di scansione a ritroso dell'insieme Properties, che si interrompe
    ' quando si incontra la prima proprietà NON Custom, visto che le
    ' proprietà Custom sono tutte accodate alla fine di Properties
    ' (poiché possono essere inserite in Properties soltanto col
    ' metodo Append).
    '------------------------------------------------------------------------
    For i = obj.Properties.Count - 1 To 0 Step -1
        Set prp = obj.Properties(i)
        '--------------------------------------------------------------------
        ' Salvataggio di prp per l'eventuale reinserimento
        ' nell'insieme Properties.
        '--------------------------------------------------------------------
        With prp
            prpName = .Name
            prpType = .Type
            prpValue = .Value
        End With
        '--------------------------------------------------------------------
        ' Tentativo di rimozione della proprietà prp dall'insieme Properties.
        '--------------------------------------------------------------------
        obj.Properties.Delete prpName
        '--------------------------------------------------------------------
        ' La rimozione di prp NON genera un errore SE e SOLO SE prp è Custom.
        ' In questo caso pertanto prp deve essere reinserita in Properties e
        ' salvata in customProperties.
        '--------------------------------------------------------------------
        Set prp = obj.CreateProperty(prpName, prpType, prpValue)
        obj.Properties.Append prp
        customProperties.Add prp
    Next i

'-----------------------------------------------------------------------------
' Quando la rimozione di prp fallisce per la prima volta (causando un errore)
' si salta direttamente a doExit:, essendovi la certezza che non esiste alcuna
' altra proprietà Custom nell'insieme Properties.
'-----------------------------------------------------------------------------
doExit:
End Sub

'-------------------------------------------------------------------------
' Subroutine di test.
'-------------------------------------------------------------------------
Sub prova1()
    Dim dbs As Database, collectionProva As New Collection, prp As Property

    Set dbs = CurrentDb

    ' Aggiunge qualche proprietà Custom per scopi di test.
    Set prp = dbs.CreateProperty("Pippo", dbText, "Pippo")
    dbs.Properties.Append prp
    Set prp = dbs.CreateProperty("Pluto", dbText, "Pluto")
    dbs.Properties.Append prp
    Set prp = dbs.CreateProperty("Topolino", dbText, "Topolino")
    dbs.Properties.Append prp

    extractCustomProperties dbs, collectionProva
    ' Ripristina l'ordine originario di dbs.Properties.
    Set collectionProva = Nothing
    extractCustomProperties dbs, collectionProva

    ' Stampa i nomi delle (sole) proprietà Custom.
    For Each prp In collectionProva
        Debug.Print prp.Name
    Next prp

    ' Rimuove le proprietà Custom di test.
    dbs.Properties.Delete "Pippo"
    dbs.Properties.Delete "Pluto"
    dbs.Properties.Delete "Topolino"
End Sub

'-------------------------------------------------------------------------
' Questo esempio recupera le proprietà Custom che possono essere inserite
' tramite il menu
' File/Proprietà database/Personalizza
' di Access 97
'-------------------------------------------------------------------------
Sub prova2()
    Dim prp As Property, dbs As Database, doc As Document
    Dim collectionProva As New Collection

    Set dbs = CurrentDb
    Set doc = dbs.Containers!Databases.Documents!UserDefined

    extractCustomProperties doc, collectionProva
    Set collectionProva = Nothing
    extractCustomProperties doc, collectionProva

    For Each prp In collectionProva
        Debug.Print prp.Name
    Next prp
End Sub