Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Geometry
Imports RTree

Public Class MyCell
    Public Box As Line 'Размер ячейки
    Public Col As Integer
    Public Row As Integer
    Public Value As String

    Public Sub New()
        Box = Nothing
        Col = 0
        Row = 0
        Value = ""
    End Sub

    Public Sub New(nBox As Line, wCol As Integer, wRow As Integer, nValue As String)
        Box = nBox
        Col = wCol
        Row = wRow
        Value = nValue
    End Sub

    Public Function GetH() As Double
        Return Box.EndPoint.Y - Box.StartPoint.Y
    End Function

    Public Function GetW() As Double
        Return Box.EndPoint.X - Box.StartPoint.X
    End Function

    Public Function GetRectangle() As Rectangle
        Return New Rectangle(Box.StartPoint.X, Box.StartPoint.Y, Box.EndPoint.X, Box.EndPoint.Y, 0, 0)
    End Function

End Class

Imports MyAcAs = Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports RTree

Public Class MyTable
    'Public Shared MinColW As Double = 1
    'Public Shared MinRowH As Double = 1
    Private vert, horz As List(Of Line) 'Список линий формирующих таблицу
    Public Cells(,) As MyCell 'Массив ячеек
    Friend wTree As RTree(Of MyCell) 'Дерево для поиска ячеек

    Public Enum Orent
        Vert ' вертикальна
        Horz ' горизонтална
        None ' неопределенна
    End Enum

    Public Shared Function isOrto(wL As Line) As Orent
        'Определяем орентацию линии - вертикальна или горизонтална
        Dim wValue As Double = wL.Angle / Math.PI
        Dim delta As Double = 0.05
        wValue = wValue - Math.Truncate(wValue + delta / 2)
        If Math.Abs(wValue) <= delta Then
            Return Orent.Horz
        ElseIf (Math.Abs(wValue) < 0.5 + delta) And (Math.Abs(wValue) > 0.5 - delta) Then
            Return Orent.Vert
        Else
            Return Orent.None
        End If
    End Function

    Private Shared Function CompareByX(l1 As Line, l2 As Line) As Integer
        If l1.StartPoint.X > l2.StartPoint.X Then
            Return 1
        ElseIf l1.StartPoint.X = l2.StartPoint.X Then
            Return 0
        Else
            Return -1
        End If
    End Function

    Private Shared Function CompareByY(l1 As Line, l2 As Line) As Integer
        If l1.StartPoint.Y > l2.StartPoint.Y Then
            Return 1
        ElseIf l1.StartPoint.Y = l2.StartPoint.Y Then
            Return 0
        Else
            Return -1
        End If
    End Function

    Private Shared Function GetSelect(ed As Editor) As ObjectId()
        'Получаем от пользователя набор данных для парсинга
        Dim PSResult As PromptSelectionResult
        Dim wTV() As TypedValue = {New TypedValue(DxfCode.Operator, "<or"), _
                                   New TypedValue(DxfCode.Start, "LINE"), _
                                   New TypedValue(DxfCode.Start, "LWPOLYLINE"), _
                                   New TypedValue(DxfCode.Start, "TEXT"), _
                                   New TypedValue(DxfCode.Start, "MTEXT"), _
                                   New TypedValue(DxfCode.Operator, "or>")}
        Dim wSF As New SelectionFilter(wTV)
        PSResult = ed.GetSelection(wSF)
        If PSResult.Status = PromptStatus.OK Then
            Return PSResult.Value.GetObjectIds()
        Else
            Return Nothing
        End If
    End Function

    Private Shared Function PolyToLine(pl As Polyline) As List(Of Line)
        Dim wList As New List(Of Line)
        Dim wL As Line
        For i = 0 To pl.NumberOfVertices - 2
            wL = New Line(pl.GetPoint3dAt(i), pl.GetPoint3dAt(i + 1))
            wList.Add(wL)
        Next
        Return wList
    End Function

    Private Sub New(nvert As List(Of Line), nhorz As List(Of Line))
        'Формируем "пустую" таблицу из линий
        Me.vert = nvert
        Me.horz = nhorz
        Dim CC, RC As Integer
        CC = Me.GetCols()
        RC = Me.GetRows()
        ReDim Me.Cells(CC, RC)
        Me.wTree = New RTree(Of MyCell)()
        Dim wLine As Line
        Dim nCell As MyCell
        For i = 0 To CC - 1
            For j = 0 To RC - 1
                wLine = Me.GetCellBox(i, j)
                nCell = New MyCell(wLine, i, j, "")
                Me.Cells(i, j) = nCell
                Me.wTree.Add(nCell.GetRectangle, nCell)
            Next
        Next
    End Sub

    Public Sub SetValue(wt As DBText)
        'Заполняем таблицу
        If wt.Bounds IsNot Nothing Then
            Dim tExtent As Extents3d = wt.Bounds
            Dim X, Y As Double
            X = (tExtent.MaxPoint.X + tExtent.MinPoint.X) / 2
            Y = (tExtent.MaxPoint.Y + tExtent.MinPoint.Y) / 2
            Dim wP As New Point(X, Y, 0)
            Dim wList As List(Of MyCell) = Me.wTree.Nearest(wP, wt.Height / 2)
            If wList IsNot Nothing Then
                If wList.Count > 0 Then wList(0).Value = wt.TextString
            End If
        End If
    End Sub

    Public Sub SetValue(wt As MText)
        'Заполняем таблицу
        If wt.Bounds IsNot Nothing Then
            Dim tExtent As Extents3d = wt.Bounds
            Dim X, Y As Double
            X = (tExtent.MaxPoint.X + tExtent.MinPoint.X) / 2
            Y = (tExtent.MaxPoint.Y + tExtent.MinPoint.Y) / 2
            Dim wP As New Point(X, Y, 0)
            Dim wList As List(Of MyCell) = Me.wTree.Nearest(wP, 1)
            If wList IsNot Nothing Then
                If wList.Count > 0 Then wList(0).Value = wt.Text
            End If
        End If
    End Sub

    Private Shared Function CrTbl(wList As List(Of Line)) As MyTable
        'Формируем "пустую" таблицу из линий
        Dim nvert, nhorz, overt, ohorz As List(Of Line)
        nvert = wList.FindAll(Function(l) isOrto(l) = Orent.Vert)
        nvert.Sort(AddressOf CompareByX)
        nhorz = wList.FindAll(Function(l) isOrto(l) = Orent.Horz)
        nhorz.Sort(AddressOf CompareByY)
        '
        Dim MinColW, MinRowH As Double
        MinColW = Math.Abs(nvert(0).StartPoint.X - nvert(nvert.Count - 1).StartPoint.X) * 0.01
        MinRowH = Math.Abs(nhorz(0).StartPoint.Y - nhorz(nhorz.Count - 1).StartPoint.Y) * 0.01
        '
        Dim ol As Line = Nothing
        overt = New List(Of Line)
        For Each l In nvert
            If ol Is Nothing Then
                ol = l
                overt.Add(l)
            Else
                If Math.Abs(l.StartPoint.X - ol.StartPoint.X) > MinColW Then
                    ol = l
                    overt.Add(l)
                End If
            End If
        Next
        '
        ohorz = New List(Of Line)
        For Each l In nhorz
            If ol Is Nothing Then
                ol = l
                ohorz.Add(l)
            Else
                If Math.Abs(l.StartPoint.Y - ol.StartPoint.Y) > MinRowH Then
                    ol = l
                    ohorz.Add(l)
                End If
            End If
        Next
        Return New MyTable(overt, ohorz)
    End Function

    Public Shared Function CrTbl(acDoc As MyAcAs.Document) As MyTable
        'Создаём таблицу
        Dim ed As Editor = acDoc.Editor
        Dim objIdArray() As ObjectId = MyTable.GetSelect(ed) 'Получаем от пользователя набор данных для парсинга
        If objIdArray IsNot Nothing Then
            Dim dbObj As DBObject
            Dim wList As New List(Of Line)
            Dim wTList As New List(Of DBText)
            Dim wMTList As New List(Of MText)
            Using tr As Transaction = acDoc.Database.TransactionManager.StartTransaction
                Try
                    For Each objId As ObjectId In objIdArray
                        dbObj = tr.GetObject(objId, OpenMode.ForRead)
                        'Сортируем полученные объекты
                        Select Case True
                            Case TypeOf dbObj Is Line
                                wList.Add(dbObj)
                            Case TypeOf dbObj Is Polyline
                                wList.AddRange(MyTable.PolyToLine(dbObj))
                            Case TypeOf dbObj Is DBText
                                wTList.Add(dbObj)
                            Case TypeOf dbObj Is MText
                                wMTList.Add(dbObj)
                        End Select
                    Next
                    tr.Commit()
                Catch ex As Exception
                    ed.WriteMessage(ex.ToString())
                    tr.Abort()
                End Try
            End Using
            '
            Dim wMTbl As MyTable = MyTable.CrTbl(wList)
            'Заполняем текстом
            For Each wt In wTList
                wMTbl.SetValue(wt)
            Next
            For Each wmt In wMTList
                wMTbl.SetValue(wmt)
            Next
            Return wMTbl
        Else
            Return Nothing
        End If
    End Function

    Public Function GetCols() As Integer
        Return vert.Count - 1
    End Function

    Public Function GetColW(i As Integer) As Double
        Dim res As Double = Math.Abs(vert(i + 1).StartPoint.X - vert(i).StartPoint.X)
        If res = 0 Then res = 1 '?!
        Return res
    End Function

    Public Function GetRows() As Integer
        Return horz.Count - 1
    End Function

    Public Function GetRowH(j As Integer) As Double
        Dim res As Double = Math.Abs(horz(j + 1).StartPoint.Y - horz(j).StartPoint.Y)
        If res = 0 Then res = 1 '?!
        Return res
    End Function

    Public Function GetCellBox(i As Integer, j As Integer) As Line
        'Получаем диагональную линию в нужной ячейке (размер)
        Dim p1, p2 As Point3d
        p1 = New Point3d(vert(i).StartPoint.X, horz(j).StartPoint.Y, 0)
        p2 = New Point3d(vert(i + 1).StartPoint.X, horz(j + 1).StartPoint.Y, 0)
        Return New Line(p1, p2)
    End Function

    Public Function CrTbl(ip As Point3d) As Table
        'Создаём ACAD-таблицу
        Dim res As New Table()
        Dim Rs, Cs As Integer
        Rs = Me.GetRows()
        Cs = Me.GetCols()
        res.SetSize(Rs, Cs)
        res.Position = ip
        For i = 0 To Cs - 1
            res.Columns(i).Width = Me.GetColW(i)
            For j = 0 To Rs - 1
                res.Rows(j).Height = Me.GetRowH(j)
                res.Cells(Rs - j - 1, i).TextString = Me.Cells(i, j).Value
            Next
        Next
        res.GenerateLayout() '!?
        Return res
    End Function

End Class

Imports Autodesk.AutoCAD.Runtime
Imports MyAcAs = Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.DatabaseServices

Public Class AcadWork

    <CommandMethod("TblParse")> _
    Public Sub TblParse()
        Dim acDoc As MyAcAs.Document = MyAcAs.Application.DocumentManager.MdiActiveDocument
        Dim ed As Editor = acDoc.Editor
        Dim wMTbl As MyTable = MyTable.CrTbl(acDoc)
        '
        Dim PPResult As PromptPointResult
        PPResult = ed.GetPoint("Точка вставки")
        If PPResult.Status = PromptStatus.OK Then
            Dim nTbl As Table = wMTbl.CrTbl(PPResult.Value)
            Using tr As Transaction = acDoc.Database.TransactionManager.StartTransaction
                Try
                    Dim bt As BlockTable = tr.GetObject(acDoc.Database.BlockTableId, OpenMode.ForRead)
                    Dim btr As BlockTableRecord = tr.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
                    btr.AppendEntity(nTbl)
                    tr.AddNewlyCreatedDBObject(nTbl, True)
                    tr.Commit()
                Catch ex As Exception
                    ed.WriteMessage(ex.ToString())
                    tr.Abort()
                End Try
            End Using
        End If
    End Sub

End Class