openaccess/source/modules/VCS_Properties.bas

Option Compare Database
Option Explicit

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

Public Sub ExportProperties(daoObject As Object, 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
    
    VCS_Dir.MkDirIfNotExist Left$(file_path, InStrRev(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

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
        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
            Call CreateProperty(daoObject, prp_name, prp_value, prp_type)
        Case 3421
            Call logger("SetOrCreateProperty", "ERROR", prp_name & " : Type is not compatible with property (" & prp_value & ", " & prp_type & ")")
        Case Else
            If Not IgnoreReadOnly Then
                Call logger("SetOrCreateProperty", "ERROR", prp_name & " : Property is read only")
            End If
    End Select
  
End Sub

Public Sub CreateProperty(ByRef daoObject As Object, ByVal prp_name As String, ByVal prp_value As String, ByVal prp_type As Integer)
    On Error GoTo err
    Dim prp As Object
    Set prp = daoObject.CreateProperty(prp_name, prp_type, prp_value)
    daoObject.Properties.Append prp
    Exit Sub
err:
    Call logger("CreateProperty", "ERROR", prp_name & "> Unable to create the property (" & 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 = CLng(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

Sub test()
    Dim prp As Object
    
    For Each prp In CurrentDb.Properties
        Call isReadOnly(prp)
        'Debug.Print prp.name, isReadOnly(prp)
    
    Next prp
    
End Sub