Создание базы данных в Access с площадью полилиний

Option Explicit
' Request Refereces to:
' Microsof Access 11.0 Object Library
' Microsoft ADO Ext. 2.8 for DLL and Security
' Microsoft ActiveX Data Objects 2.8 Library
Sub WritePlinesToDatabase()
    On Error GoTo ErrHandler
    Dim adoxCat As ADOX.Catalog
    Set adoxCat = New ADOX.Catalog
    Call ADOXCreateTable(adoxCat)
    adoxCat.ActiveConnection = Nothing
    Set adoxCat = Nothing
    DoEvents
    ' Variables for AutoCAD Objects
    Dim oSset As AcadSelectionSet
    Dim oEnt As AcadEntity
    Dim oPLine As AcadLWPolyline
    Dim groupCode(0) As Integer
    Dim dataValue(0) As Variant
    ' Variables for ADO Objects
    Dim wsPath As String, conString As String
    Dim db As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    ' Connect to the database
    Dim tblName As String
    tblName = "tblPlines"
    Dim strSQL As String  'SQL string for extracting recorsets.
    strSQL = "INSERT INTO [" & tblName & "]"
    With db
        .CursorLocation = adUseServer
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Data Source").Value = "C:\plines.mdb"    ' <-- change database name here
        .Open
    End With
    With rst
        .LockType = adLockPessimistic
        .ActiveConnection = db
        .CursorType = adOpenKeyset
        .CursorLocation = adUseServer
        .Source = strSQL
    End With
    If Err <> 0 Then
        MsgBox "Could not open table. Make sure " & _
               "it has been configured in the DbConnect Manager."
        Exit Sub
    End If
    ' clean up table:
    db.Execute "DELETE FROM [" & tblName & "]"
    ' Open the polyline recordset
    rst.Open tblName, db, adOpenDynamic, adLockOptimistic
    If Err <> 0 Then
        MsgBox "Could not open spaces recordset"
        Exit Sub
    End If
    ' Make sure the Recordset supports AddNew
    If Not rst.Supports(adAddNew) Then
        MsgBox "Cannot add records to the recordset."
        Exit Sub
    End If
    On Error Resume Next
    ' Get the selection set of all hatches in the current drawing
    With ThisDrawing.SelectionSets
        While .Count > 0
            .Item(0).Delete
        Wend
        Set oSset = .Add("NewOne")
    End With
    groupCode(0) = 0
    dataValue(0) = "LWPOLYLINE"
    Dim cnt As Integer
    cnt = 1
    oSset.Clear
    oSset.Select acSelectionSetAll, , , groupCode, dataValue
    ' Loop through the selection and add the hatch data to the database
    For Each oEnt In oSset
        Set oPLine = oEnt
        ' Add a new blank record
        rst.AddNew
        ' Set the field values
        rst!ID = cnt
        rst!Handle = oPLine.Handle
        rst!Layer = oPLine.Layer
        rst!Length = Round(oPLine.Length, 3)
        ' Commit the changes
        rst.Update
        rst.MoveNext
        cnt = cnt + 1
    Next
    ' Close the recordset and the database connection
    rst.Close
    db.Close
    Set rst = Nothing
    Set db = Nothing
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description
    End If
End Sub
Public Sub ADOXCreateTable(adoxCat As ADOX.Catalog)
    On Error GoTo ErrCreateTable
    Dim adoxTbl As New ADOX.Table
    Dim adoxCol As ADOX.Column
    Set adoxCat = New ADOX.Catalog
    adoxCat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & vbCr & _
                               "Data Source = " & "C:\plines.mdb "' <-- change database name here
    With adoxTbl
        .Name = "tblPlines"
        Set adoxCol = New ADOX.Column
        With adoxCol
            .ParentCatalog = adoxCat
            .Name = "ID"
            .Type = adInteger
            .Properties("AutoIncrement").Value = True    '
        End With
        .Columns.Append adoxCol, adInteger
        .Keys.Append "PrimaryKey", adKeyPrimary, "ID"
        Set adoxCol = New ADOX.Column
        With adoxCol
            .ParentCatalog = adoxCat
            .Name = "Handle"
            .Type = adVarWChar
            .DefinedSize = 12
            .Properties("Description").Value = "Polyline Handle"
        End With
        .Columns.Append adoxCol, adVarWChar
        Set adoxCol = New ADOX.Column
        With adoxCol
            .ParentCatalog = adoxCat
            .Name = "Layer"
            .Type = adVarWChar
            .DefinedSize = 20
            .Properties("Description").Value = "Polyline Layer"
        End With
        .Columns.Append adoxCol, adVarWChar
        Set adoxCol = New ADOX.Column
        With adoxCol
            .ParentCatalog = adoxCat
            .Name = "Length"
            .Type = adDouble
            .DefinedSize = 12
            .Properties("Description").Value = "Polyline Length"
        End With
        .Columns.Append adoxCol, adDouble
        adoxCat.Tables.Append adoxTbl
    End With
    Set adoxCol = Nothing
    Set adoxTbl = Nothing
ErrCreateTable:
    If Err.Number <> 0 Then
        MsgBox "Error of the table creation"
    End If
End Sub