Imports System
Imports Microsoft.Office.Interop
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Colors
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.GraphicsInterface
Imports Autodesk.AutoCAD.Internal
Imports Autodesk.AutoCAD.ApplicationServices.Application
Imports Autodesk.AutoCAD.Runtime.Interop
Imports AcadRT = Autodesk.AutoCAD.Runtime
Imports AcadED = Autodesk.AutoCAD.EditorInput
Imports AcadDB = Autodesk.AutoCAD.DatabaseServices
Imports AcadApp = Autodesk.AutoCAD.ApplicationServices.Application
Public Class AcadTableUtilities
<CommandMethod("ITA", CommandFlags.Modal Or CommandFlags.Session)> _
Public Sub addTable()
Dim adoc As Document = AcadApp.DocumentManager.MdiActiveDocument
Dim ed As Editor = adoc.Editor
Dim lock As DocumentLock = adoc.LockDocument()
Dim dbase As Database = HostApplicationServices.WorkingDatabase
Using trans As Transaction = dbase.TransactionManager.StartTransaction()
Try
Dim Path As String = "C:\MyVBA\Layers.xls" '// изменить на свое
Dim arr(,) As String = ReadExcel(Path)
Dim nmRows As Int32 = UBound(arr, 1) + 3
Dim nmColumns As Int32 = UBound(arr, 2) + 1
Dim position As Point3d = New Point3d(2.0, 2.0, 0.0)
Dim rowHeight As Double = 0.2
Dim blkTbl As BlockTable = CType(trans.GetObject(dbase.BlockTableId, OpenMode.ForRead),
BlockTable)
Dim blkTblRec As BlockTableRecord = CType(trans.GetObject(blkTbl(BlockTableRecord.ModelSpace),
OpenMode.ForWrite), BlockTableRecord)
Dim styDef As ObjectId = makeTableStyle()
Dim myTable As Table = New Table()
myTable.IsHeaderSuppressed = False
myTable.IsTitleSuppressed = False
myTable.NumColumns = nmColumns
myTable.NumRows = nmRows
myTable.Height = nmRows * rowHeight
myTable.Position = position
myTable.TableStyle = styDef
blkTblRec.AppendEntity(myTable)
trans.AddNewlyCreatedDBObject(myTable, True)
myTable.RecomputeTableBlock(False)
myTable.GenerateLayout()
myTable.SetTextString(0, 0, "Title goes here") '// изменить на свое
Dim trg As TableRegion = New TableRegion(0, 0, 0, CInt(UBound(arr, 2)))
myTable.MergeCells(trg)
Dim hdl(2) As String
hdl(0) = "Layer" '// изменить на свое
hdl(1) = "LineType" '// изменить на свое
hdl(2) = "Color" '// изменить на свое
For i As Int32 = 0 To UBound(arr, 1)
For j As Int32 = 0 To UBound(arr, 2)
Dim s As String
s = arr(i, j)
myTable.SetValue(i + 2, j, s, ParseOption.SetDefaultFormat)
Next
Next
myTable.SetColumnWidth(0, 2)
myTable.SetColumnWidth(1, 3)
myTable.SetColumnWidth(2, 1.5)
myTable.SetTextHeight(0.2, 2) 'title row
myTable.SetTextHeight(0.15, 4) 'header row
myTable.SetTextHeight(0.1, 1) 'data row
myTable.RecomputeTableBlock(True)
ed.Regen()
myTable.Dispose()
blkTbl.Dispose()
blkTblRec.Dispose()
Catch ex As System.Exception
MsgBox(ex.StackTrace)
End Try
trans.Commit()
trans.Dispose()
End Using
End Sub
Private Function makeTableStyle() As ObjectId
Dim styDef As ObjectId = ObjectId.Null
Dim color1 As Color = Color.FromColorIndex(ColorMethod.ByAci, 1)
Dim color2 As Color = Color.FromColorIndex(ColorMethod.ByAci, 2)
Dim color3 As Color = Color.FromColorIndex(ColorMethod.ByAci, 3)
Dim dbase As Database = HostApplicationServices.WorkingDatabase
Dim trans As Transaction = dbase.TransactionManager.StartTransaction()
Dim listStyle As TableStyle = New TableStyle()
Dim tblStyle As DBDictionary = CType(trans.GetObject(dbase.TableStyleDictionaryId, OpenMode.ForRead,
False), DBDictionary)
Try
listStyle = CType(trans.GetObject(tblStyle.GetAt("LayerData"), OpenMode.ForRead), TableStyle) '// изменить
на свое
Catch
tblStyle.UpgradeOpen()
styDef = tblStyle.SetAt("LayerData", listStyle) '// изменить на свое
listStyle.Name = "Layer list" '// изменить на свое
listStyle.Description = "Table style for layer list" '// изменить на свое
listStyle.IsHeaderSuppressed = False
listStyle.IsTitleSuppressed = False
listStyle.SetGridLineWeight(LineWeight.LineWeight100, 1, 2)
listStyle.SetGridLineWeight(LineWeight.LineWeight100, 1, 1)
listStyle.SetGridLineWeight(LineWeight.LineWeight100, 8, 1)
listStyle.SetGridLineWeight(LineWeight.LineWeight100, 4, 1)
listStyle.SetTextHeight(0.2, 2) 'title row
listStyle.SetTextHeight(0.15, 4) 'header row
listStyle.SetTextHeight(0.1, 1) 'data row
listStyle.SetAlignment(CellAlignment.MiddleCenter, 2) 'title row
listStyle.SetAlignment(CellAlignment.MiddleCenter, 4) 'header row
listStyle.SetAlignment(CellAlignment.MiddleCenter, 1) 'data row
listStyle.SetColor(color1, 2) 'title row
listStyle.SetColor(color2, 4) 'header row
listStyle.SetColor(color3, 1) 'data row
trans.AddNewlyCreatedDBObject(listStyle, True)
End Try
trans.Commit()
Return styDef
End Function
Friend Function ReadExcel(ByVal Path As String) As String(,)
Dim app As Excel.ApplicationClass = New Excel.ApplicationClass
Dim workBook As Excel.Workbook = app.Workbooks.Open(Path, 0, True, 5, "", "", True,
Excel.XlPlatform.xlWindows, "" & Microsoft.VisualBasic.Chr(9) & "", False, False, 0, True, 1, 0)
Dim workSheet As Excel.Worksheet = CType(workBook.Worksheets(1), Excel.Worksheet)
Dim SheetRange As Excel.Range = CType(workSheet.UsedRange, Excel.Range)
Dim rowIndex As Long = SheetRange.Rows.Count
Dim colIndex As Long = SheetRange.Columns.Count
Dim valArray(0 To rowIndex - 1, 0 To colIndex - 1) As String
Dim itm As String
Try
For i As Long = 1 To rowIndex
For j As Long = 1 To colIndex
Dim val As String = CType(SheetRange.Cells(i, j), Excel.Range).Value.ToString
If Not val Is Nothing Then
itm = val
Else
itm = "Empty"
End If
valArray(i - 1, j - 1) = itm
Next
Next
Catch ex As Autodesk.AutoCAD.Runtime.Exception
app.Quit()
End Try
Return valArray
End Function
End Class