Reading Databases with ADOX library

[peter]

I have used the DAO type library for years and ADO now for a year or so for reading databases into LISP.

This code accepts a database file name and an sql string to create a record set that is converted into a list of sublists (first sublist is the fields)

Imports System
Imports Autodesk.AutoCAD
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.Windows
Imports ACADApplication = Autodesk.AutoCAD.ApplicationServices.Core.Application
Imports ADOX

Public Class Class1

    ' Global Flags set to 3 is a flag that prints messages to both command line, 
    ' console and set to 7 to display message box if desired.
    Shared globalFlags As Int16 = 1 + 2
#Region "Public Access Data Object (ADOX) functions"
    ''' <summary>
    ''' 
    ''' </summary>
    ''' <param name="rbfArguments"></param>
    ''' <returns></returns>
    ''' <remarks>LISP Syntax: (ADOXToList "c:\\acad\\newmdb.mdb" "Select FirstName, LastName, Address From AddressTable where LastName Like '%'"")
    ''' </remarks>
    <LispFunction("ADOXtoList")> _
    Public Function ADOXToList(ByVal rbfArguments As ResultBuffer)
        Try
            Dim arrArguments As TypedValue() = rbfArguments.AsArray
            If arrArguments.Length > 1 Then
                Dim strFullName As String = FileFind(arrArguments(0).Value.ToString)
                If strFullName Is Nothing Then
                    MessageWrite("File ''" & arrArguments(0).Value.ToString & "'' Not Found", globalFlags)
                    Return Nothing
                End If
                Return DatabaseRead(strFullName, arrArguments(1).Value.ToString)
            End If
            MessageWrite("error: Too Few Arguments", globalFlags)
        Catch exception As System.Exception
            ErrorMessage(Err, globalFlags)
        End Try
        Return Nothing
    End Function
    ''' <summary>
    '''  Function to read a database given a filename and a strucutred queiry language statement
    '''  and return the recordset as a list of sublists
    ''' </summary>
    ''' <param name="strFullName"></param>
    ''' <param name="strSQL"></param>
    ''' <returns></returns>
    Public Function DatabaseRead(ByVal strFullName As String, ByVal strSQL As String)
        Dim connection As New ADODB.Connection
        Dim catalog As New ADOX.Catalog
        Dim recordSet As New ADODB.Recordset
        Try
            Dim rbfReturn As New ResultBuffer
            Dim strConnection As String = ConnectionString(strFullName)
            If strConnection IsNot Nothing Then
                connection.Open(strConnection)
                catalog.ActiveConnection = connection
                recordSet = connection.Execute(strSQL)

                If recordSet IsNot Nothing Then
                    rbfReturn = RecordSetToResultBuffer(recordSet)
                End If
                'Clean up
                connection.Close()
                catalog = Nothing
                connection = Nothing
                Return rbfReturn
            End If
            Return Nothing
        Catch exception As System.Exception
            catalog = Nothing
            If connection IsNot Nothing Then
                If connection.State = 1 Then connection.Close()
            End If
            connection = Nothing
            ErrorMessage(Err, globalFlags)
            Return Nothing
        End Try

    End Function
    ''' <summary>
    ''' Function to convert a record set to a list of sublists
    ''' </summary>
    ''' <param name="recordset"></param>
    ''' <returns>ResultBuffer (list of sublists)</returns>
    Public Function RecordSetToResultBuffer(ByVal recordset As ADODB.Recordset)
        Try
            Dim rbfReturn As New ResultBuffer
            If recordset IsNot Nothing And Not recordset.BOF Then
                recordset.MoveFirst()
                rbfReturn.Add(New TypedValue(5016, -1))
                rbfReturn.Add(New TypedValue(5016, -1))
                For Each field As ADODB.Field In recordset.Fields
                    rbfReturn.Add(New TypedValue(5005, field.Name))
                Next
                rbfReturn.Add(New TypedValue(5017, -1))
                Do While Not recordset.EOF
                    rbfReturn.Add(New TypedValue(5016, -1))
                    For Each field As ADODB.Field In recordset.Fields
                        rbfReturn.Add(ObjectToTypedValue(field.Value))
                    Next
                    recordset.MoveNext()
                    rbfReturn.Add(New TypedValue(5017, -1))
                Loop
                rbfReturn.Add(New TypedValue(5017, -1))
                Return rbfReturn
            End If
        Catch exception As System.Exception
            ErrorMessage(Err, globalFlags)
        End Try
        Return Nothing
    End Function

    ''' <summary>
    ''' Function to get the correct connection string for each type of database file 
    ''' and 64 bit and 32 bit architectures.
    ''' </summary>
    ''' <param name="strFullName"></param>
    ''' <param name="blnSecurity"></param>
    ''' <returns>Connection String as string or nothing </returns>

    Private Function ConnectionString(ByVal strFullName As String, _
                                      Optional ByVal blnSecurity As Boolean = False)
        Try
            Dim strProvider As String = Nothing
            Select Case System.IO.Path.GetExtension(strFullName).ToUpper
                Case ".ACCDB"
                    strProvider = "Microsoft.ACE.OLEDB.12.0; Data Source="
                Case ".MDB"
                    If IntPtr.Size = 8 Then '<- 8 is 64x architecture
                        strProvider = "Microsoft.ACE.OLEDB.12.0; Data Source="
                    Else
                        strProvider = "Microsoft.Jet.OLEDB.4.0; Data Source="
                    End If
                Case ".MDF" Or ".UDF"
                    strProvider = "Microsoft.Jet.OLEDB.4.0; Data Source="
            End Select
            If strProvider IsNot Nothing Then
                Return "Provider=" & strProvider & "'" & strFullName & "'" & ";Persist Security Info=" & blnSecurity.ToString & ";"
            End If

        Catch exception As System.Exception
            ErrorMessage(Err, globalFlags)
        End Try

        Return Nothing
    End Function
#End Region

    ' Region of Message Functions
#Region "Public Error Message functions"
    ''' <summary>
    ''' Sub routine for printing error messages to the command line and console
    ''' </summary>
    ''' <param name="objError"></param>
    ''' <param name="flags"></param>
    ''' 
    Public Shared Sub ErrorMessage(ByVal objError As ErrObject, Optional ByVal flags As Int16 = 3)
        If objError.Number <> 0 Then
            Dim strMessage As String = objError.Source & "-->" & objError.Description
            MessageWrite(strMessage, flags)
        End If
    End Sub

    ''' <summary>
    ''' Function for finding a file in the AutoCAD search path or specified folder.
    ''' </summary>
    ''' <param name="strFullName"></param>
    ''' <returns>File Full Name with Path </returns>

    Public Shared Function FileFind(ByVal strFullName As String)
        Try
            Dim database = HostApplicationServices.WorkingDatabase
            strFullName = HostApplicationServices.Current.FindFile(strFullName, database, FindFileHint.Default)
            If strFullName IsNot Nothing Then
                Return strFullName
            End If
        Catch exception As System.Exception
            ErrorMessage(Err, globalFlags)
        End Try
        Return Nothing
    End Function

    ''' <summary>
    ''' Sub routine for writing to command line, console and/or message box.
    ''' </summary>
    ''' <param name="strMessage"></param>
    ''' <param name="flags"></param>
    ''' <remarks>
    ''' 0 Dont write messages to command line or console
    ''' 1 Write Message to Console
    ''' 2 Write Message to Command Line
    ''' 4 Write in a message box
    ''' </remarks>
    Public Shared Sub MessageWrite(ByVal strMessage As String, Optional ByVal flags As Int16 = 3)
        If (flags And 1) = 1 Then _
            Console.WriteLine(strMessage.ToString)
        If (flags And 2) = 2 Then _
            ACADApplication.DocumentManager.MdiActiveDocument.Editor.WriteMessage(strMessage.ToString)
        If (flags And 4) = 4 Then _
            MsgBox(strMessage.ToString)
    End Sub

#End Region


End Class

[peter]

This region needs to be added to the above class (I ran out of room)

#Region "Public ObjectToTypedValueer functions"
    '  Blank (like returned by princ)
    Public Shared Function ObjectToTypedValue() As TypedValue
        Return New TypedValue(LispDataType.None, -1)
    End Function

    ' Integers (32 bit or other)
    Public Shared Function ObjectToTypedValue(value As Integer) As TypedValue
        Return New TypedValue(LispDataType.Int16, value)
    End Function

    ' 16 bit integers
    Public Shared Function ObjectToTypedValue(value As Int16) As TypedValue
        Return New TypedValue(LispDataType.Int16, value)
    End Function

    ' Doubles
    Public Shared Function ObjectToTypedValue(value As Double) As TypedValue
        Return New TypedValue(LispDataType.Double, value)
    End Function

    ' Strings
    Public Shared Function ObjectToTypedValue(value As String) As TypedValue
        Return New TypedValue(LispDataType.Text, value)
    End Function

    ' Booleans
    Public Shared Function ObjectToTypedValue(value As Boolean) As TypedValue
        If CBool(value) Then
            Return New TypedValue(LispDataType.T_atom, -1)
        End If
        Return New TypedValue(LispDataType.Nil, -1)
    End Function

    ' 2d Points
    Public Shared Function ObjectToTypedValue(value As Point2d) As TypedValue
        Return New TypedValue(LispDataType.Point2d, value)
    End Function

    ' 3d Points
    Public Shared Function ObjectToTypedValue(value As Point3d) As TypedValue
        Return New TypedValue(LispDataType.Point3d, value)
    End Function

#End Region

[peter]

The reference files are:

Refernce Image.jpg

[irneb]

You might also want to check what nullptr did here: http://www.theswamp.org/index.php?topic=28286.0

I.e. an embeddable / stand-alone database file (Sqlite).

[peter]

This is a sample of calling this function from lisp

(defun C:ADOX ()
 (textscr)
 (ADOXToList "c:\\acad\\newmdb.adodb"
   "Select FirstName, LastName, ZIPCode From AddressTable where State Like 'OR'")

)

This is the function run.

Command: ADOX
(("FirstName" "LastName" "ZIPCode") ("John" "Doe" 97222) ("Jane" "Doe" 97222) ("Bill" "Note" 97208))