\n
Imports Autodesk.AutoCAD.DatabaseServices Imports Autodesk.AutoCAD.Geometry Imports RTree Public Class MyCell Public Box As Line '\u0420\u0430\u0437\u043c\u0435\u0440 \u044f\u0447\u0435\u0439\u043a\u0438 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 <\/code><\/pre>\n <\/div>\n<\/div>\n
Class MyTable<\/b><\/p>\n\n
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) '\u0421\u043f\u0438\u0441\u043e\u043a \u043b\u0438\u043d\u0438\u0439 \u0444\u043e\u0440\u043c\u0438\u0440\u0443\u044e\u0449\u0438\u0445 \u0442\u0430\u0431\u043b\u0438\u0446\u0443 Public Cells(,) As MyCell '\u041c\u0430\u0441\u0441\u0438\u0432 \u044f\u0447\u0435\u0435\u043a Friend wTree As RTree(Of MyCell) '\u0414\u0435\u0440\u0435\u0432\u043e \u0434\u043b\u044f \u043f\u043e\u0438\u0441\u043a\u0430 \u044f\u0447\u0435\u0435\u043a Public Enum Orent Vert ' \u0432\u0435\u0440\u0442\u0438\u043a\u0430\u043b\u044c\u043d\u0430 Horz ' \u0433\u043e\u0440\u0438\u0437\u043e\u043d\u0442\u0430\u043b\u043d\u0430 None ' \u043d\u0435\u043e\u043f\u0440\u0435\u0434\u0435\u043b\u0435\u043d\u043d\u0430 End Enum Public Shared Function isOrto(wL As Line) As Orent '\u041e\u043f\u0440\u0435\u0434\u0435\u043b\u044f\u0435\u043c \u043e\u0440\u0435\u043d\u0442\u0430\u0446\u0438\u044e \u043b\u0438\u043d\u0438\u0438 - \u0432\u0435\u0440\u0442\u0438\u043a\u0430\u043b\u044c\u043d\u0430 \u0438\u043b\u0438 \u0433\u043e\u0440\u0438\u0437\u043e\u043d\u0442\u0430\u043b\u043d\u0430 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() '\u041f\u043e\u043b\u0443\u0447\u0430\u0435\u043c \u043e\u0442 \u043f\u043e\u043b\u044c\u0437\u043e\u0432\u0430\u0442\u0435\u043b\u044f \u043d\u0430\u0431\u043e\u0440 \u0434\u0430\u043d\u043d\u044b\u0445 \u0434\u043b\u044f \u043f\u0430\u0440\u0441\u0438\u043d\u0433\u0430 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)) '\u0424\u043e\u0440\u043c\u0438\u0440\u0443\u0435\u043c "\u043f\u0443\u0441\u0442\u0443\u044e" \u0442\u0430\u0431\u043b\u0438\u0446\u0443 \u0438\u0437 \u043b\u0438\u043d\u0438\u0439 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) '\u0417\u0430\u043f\u043e\u043b\u043d\u044f\u0435\u043c \u0442\u0430\u0431\u043b\u0438\u0446\u0443 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) '\u0417\u0430\u043f\u043e\u043b\u043d\u044f\u0435\u043c \u0442\u0430\u0431\u043b\u0438\u0446\u0443 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 '\u0424\u043e\u0440\u043c\u0438\u0440\u0443\u0435\u043c "\u043f\u0443\u0441\u0442\u0443\u044e" \u0442\u0430\u0431\u043b\u0438\u0446\u0443 \u0438\u0437 \u043b\u0438\u043d\u0438\u0439 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 '\u0421\u043e\u0437\u0434\u0430\u0451\u043c \u0442\u0430\u0431\u043b\u0438\u0446\u0443 Dim ed As Editor = acDoc.Editor Dim objIdArray() As ObjectId = MyTable.GetSelect(ed) '\u041f\u043e\u043b\u0443\u0447\u0430\u0435\u043c \u043e\u0442 \u043f\u043e\u043b\u044c\u0437\u043e\u0432\u0430\u0442\u0435\u043b\u044f \u043d\u0430\u0431\u043e\u0440 \u0434\u0430\u043d\u043d\u044b\u0445 \u0434\u043b\u044f \u043f\u0430\u0440\u0441\u0438\u043d\u0433\u0430 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) '\u0421\u043e\u0440\u0442\u0438\u0440\u0443\u0435\u043c \u043f\u043e\u043b\u0443\u0447\u0435\u043d\u043d\u044b\u0435 \u043e\u0431\u044a\u0435\u043a\u0442\u044b 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) '\u0417\u0430\u043f\u043e\u043b\u043d\u044f\u0435\u043c \u0442\u0435\u043a\u0441\u0442\u043e\u043c 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 '\u041f\u043e\u043b\u0443\u0447\u0430\u0435\u043c \u0434\u0438\u0430\u0433\u043e\u043d\u0430\u043b\u044c\u043d\u0443\u044e \u043b\u0438\u043d\u0438\u044e \u0432 \u043d\u0443\u0436\u043d\u043e\u0439 \u044f\u0447\u0435\u0439\u043a\u0435 (\u0440\u0430\u0437\u043c\u0435\u0440) 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 '\u0421\u043e\u0437\u0434\u0430\u0451\u043c ACAD-\u0442\u0430\u0431\u043b\u0438\u0446\u0443 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 <\/code><\/pre>\n <\/div>\n<\/div>\n
\u041a\u043e\u043c\u0430\u043d\u0434\u0430<\/b><\/p>\n