openaccess/source/modules/OA_Properties.bas

Option Compare Database
Option Private Module
Option Explicit

'****
'*
'* Import/Export the properties of DAO Objects
'*
'****

Public Sub ExportProperties(ByVal daoObject As Object, ByVal file_path As String)
'exports the properties of an Access DAO object (Database, Cintainer, TableDef, Querydef, Field)
' to a file, with a TAB separator
'
    On Error GoTo err
    
    mktree parent_dir(file_path)
    
    Dim prp As Object
    Dim prp_name, prp_value, Line As String
    Dim prp_type As Integer
    Dim count As Integer
    count = 0
    
    Call logger("ExportProperties", "INFO", "Try to export the properties of '" & daoObject.name & "' to '" & file_path & "'")

    Dim objStream As ADODB.Stream
    
    Set objStream = CreateObject("ADODB.Stream")
    objStream.Open
    objStream.Type = 2 'Text
    objStream.Charset = "x-ansi"
    
    For Each prp In daoObject.Properties
        
        If Not isReadOnly(prp) Then
            
            prp_name = prp.name
            prp_value = CStr(prp.value)
            
            Line = prp_name & vbTab & prp_value & vbTab & CStr(prp.Type)
            objStream.WriteText Line, adWriteLine
            count = count + 1
            
        End If
        
    Next prp

    Call logger("ExportProperties", "INFO", "> " & count & " properties exported")

exitsub:
    objStream.SaveToFile file_path, adSaveCreateOverWrite
    objStream.Close
    Exit Sub
err:
    Call logger("ExportProperties", "ERROR", "Error during database properties export: " & err.Description)
    GoTo exitsub
'err_prop:
'    Call logger("ExportProperties", "ERROR", "Error while exporting property " & prp_name & "")
'    GoTo next_prop
End Sub

Public Sub ImportProperties(daoObject As Object, file_path As String)
'Import the properties of an EXISTING Access DAO object (Database, Cintainer, TableDef, Querydef, Field)
'! warning, it is not really stable

    On Error GoTo err
    Dim splitted_line As Variant
    Dim Line, prp_name, prp_value As String
    Dim prp_type As Integer
    Dim buffer As String
    Dim count As Integer

    Call logger("ImportProperties", "INFO", "Try to import the properties of '" & daoObject.name & "' from '" & file_path & "'")

    buffer = ReadFile(file_path, "x-ansi")
    
    count = 0
    For Each Line In Split(buffer, vbNewLine)
        If Len(Line) = 0 Then Exit For
        count = count + 1
        
        splitted_line = Split(Line, vbTab)
        prp_name = splitted_line(0)
        prp_value = splitted_line(1)
        prp_type = CInt(splitted_line(2))
        
        If prp_value <> vbNullString Then
            Call SetOrCreateProperty(daoObject, prp_name, prp_value, prp_type, True)
        End If
    Next

    Call logger("ImportProperties", "INFO", "> Done")

    Exit Sub
err:
    Call logger("ImportProperties", "ERROR", "Error during database properties import (line " & count & "): " & err.Description)
End Sub

Public Sub test_prop()
    Dim db As DAO.Database
    Dim td As DAO.TableDef
    
    Call set_debug_mode
'
'    Set db = CurrentDb
'    Set td = db.TableDefs("test")
'
'    ExportTableDef db, td, CurrentProject.path
'    db.Close
'    Set td = Nothing
'    Set db = Nothing
'
    'Call ExportTableProperties("test", CurrentProject.path)
'
    'ImportTableDef "test", CurrentProject.path
    Call ImportTableProperties("test", CurrentProject.path & "\test.properties.xml")

End Sub



Public Sub ExportTableProperties(table_name As String, dirpath As String)

    Dim db As DAO.Database
    Dim td, field As Object
    Dim prp As Property
    
    Dim oXML As MSXML2.DOMDocument60
    Dim oNode, oSubNode, oFieldNode As MSXML2.IXMLDOMNode
    Dim oElt As MSXML2.IXMLDOMElement
    Dim oAttribut As IXMLDOMAttribute
    
    dirpath = norm_dir_path(dirpath)
    mktree dirpath
    
    Set oXML = New MSXML2.DOMDocument60
    oXML.appendChild oXML.createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""")
    Set oNode = oXML.appendChild(oXML.createElement("properties"))
    Set oSubNode = oNode.appendChild(oXML.createElement("table"))

    Set db = Application.CurrentDb
    Set td = db.Containers("tables").Documents(table_name)
    
    For Each prp In td.Properties
        
        If Not isReadOnly(prp) Then
            
            Set oElt = oSubNode.appendChild(oXML.createElement(prp.name))
            If prp.Type = 1 Then
                oElt.Text = CStr(CByte(prp.value))
            Else
                oElt.Text = CStr(prp.value)
            End If
            
            Set oAttribut = oXML.createAttribute("type")
            oAttribut.Text = CStr(prp.Type)
            oElt.setAttributeNode oAttribut

        End If
    Next prp
    
    Set oSubNode = oNode.appendChild(oXML.createElement("fields"))
    
    For Each field In db.TableDefs(table_name).Fields
    
        Set oFieldNode = oSubNode.appendChild(oXML.createElement(field.name))
        
        For Each prp In field.Properties
            If Not isReadOnly(prp) Then
                Set oElt = oFieldNode.appendChild(oXML.createElement(prp.name))
                If prp.Type = 1 Then
                    oElt.Text = CStr(CByte(prp.value))
                Else
                    oElt.Text = CStr(prp.value)
                End If
                Set oAttribut = oXML.createAttribute("type")
                oAttribut.Text = CStr(prp.Type)
                oElt.setAttributeNode oAttribut
            End If
        Next prp
    Next field
    
    Dim file_path As String
    file_path = joinpaths(dirpath, table_name & ".properties.xml")
    oXML.Save file_path
    
    Call logger("ExportTableProperties", "DEBUG", "> " & table_name & " properties exported to " & file_path)
end_:
    Set oNode = Nothing
    Set oXML = Nothing

End Sub

Public Sub ImportTableProperties(table_name As String, filepath As String)

    Dim db As DAO.Database
    Dim td As Object
    Dim field As Object
    Dim prp As Property
    Dim prp_name As String
    Dim prp_value As String
    Dim prp_type As String
    Dim buffer As String
    
    Dim oXML As MSXML2.DOMDocument60
    Dim oNode As MSXML2.IXMLDOMNode
    Dim oSubNode As MSXML2.IXMLDOMNode
    Dim oFieldNode As MSXML2.IXMLDOMNode
    Dim oElt As MSXML2.IXMLDOMElement
    Dim oAttribut As IXMLDOMAttribute
    
    filepath = norm_path(filepath)
    buffer = ReadFile(filepath, "x-ansi")
    
    Set oXML = New MSXML2.DOMDocument60
    oXML.loadXML buffer

    Set db = Application.CurrentDb
    'Set td = db.Containers("tables").Documents(table_name)
    Set td = db.TableDefs(table_name)
    
    Set oNode = oXML.childNodes(1)
    
    ' "table" node
    Set oSubNode = oNode.childNodes(0)
    For Each oElt In oSubNode.childNodes
    
        prp_name = oElt.nodeName
        prp_value = oElt.Text
        prp_type = oElt.Attributes(0).Text
    
        SetOrCreateProperty td, prp_name, prp_value, prp_type
    Next oElt
    
    ' "fields" node
    Set oSubNode = oNode.childNodes(1)
    For Each oFieldNode In oSubNode.childNodes
    
        Set field = db.TableDefs(table_name).Fields(oFieldNode.nodeName)
        
        For Each oElt In oFieldNode.childNodes
        
            prp_name = oElt.nodeName
            prp_value = oElt.Text
            prp_type = oElt.Attributes(0).Text
        
            SetOrCreateProperty field, prp_name, prp_value, prp_type

        Next oElt
        
    Next oFieldNode
    
    Call logger("ImportTableProperties", "DEBUG", "> " & table_name & " properties imported from " & filepath)
end_:
    Set oNode = Nothing
    Set oXML = Nothing

End Sub


Sub SetOrCreateProperty(ByRef daoObject As Object, ByVal prp_name As String, ByVal prp_value As String, ByVal prp_type As Integer, Optional ByVal IgnoreReadOnly As Boolean = False)
    Dim prp As Object
    On Error GoTo err

        Set prp = daoObject.Properties(prp_name)
        If prp.Inherited = True Then Exit Sub
        prp.value = convert(prp_value, prp_type)
        
    Exit Sub
err:
    Select Case err.Number
        Case 3270
            ' property not found
            CreateProperty daoObject, prp_name, prp_value, prp_type
        Case 3421
            logger "SetOrCreateProperty", "ERROR", daoObject.name & " - " & prp_name & " : Type is not compatible with property (" & prp_value & ", " & prp_type & ")"
        Case Else
            logger "SetOrCreateProperty", "ERROR", daoObject.name & " - " & prp_name & " : " & err.Description
    End Select
  
End Sub

Public Sub CreateProperty(ByRef daoObject As Variant, ByVal prp_name As String, ByVal prp_value As String, ByVal prp_type As Integer)
    On Error GoTo err
    Dim prp As Object
    prp_value = convert(prp_value, prp_type)
    Set prp = daoObject.CreateProperty(prp_name, prp_type, prp_value)
    daoObject.Properties.Append prp
    Exit Sub
err:
    Call logger("CreateProperty", "ERROR", "> Unable to create the property (" & daoObject.name & " - " & prp_name & ": " & prp_value & ", " & prp_type & "): " & err.Description)
End Sub



Function convert(value As String, dbType As Integer)

   Select Case dbType
      Case dbBoolean
         convert = CBool(convert)
      Case dbByte
         convert = CByte(value)
      Case dbInteger
         convert = CInt(value)
      Case dbLong
         convert = CLng(value)
      Case dbCurrency
         convert = CCur(value)
      Case dbSingle
         convert = CSng(value)
      Case dbDouble
         convert = CDbl(value)
      Case dbDate
         convert = CDate(value)
      Case dbText
         convert = CStr(value)
      Case dbLongBinary
         convert = CStr(value)
      Case dbMemo
         convert = CStr(value)
      Case dbGUID
         convert = CStr(value)
      Case Else
         convert = CVar(value)
   End Select

End Function

Public Function isReadOnly(prp As DAO.Property) As Boolean
    On Error GoTo err
    If prp.Inherited = True Then GoTo err
    
    DAO.BeginTrans
    prp.value = prp.value
    isReadOnly = False
    DAO.Rollback
    
    Exit Function
err:
    isReadOnly = True
    DAO.Rollback
End Function