Option Explicit
Private Type ScaleFactor
X As Double 'Объявляем переменные
Y As Double
Z As Double
End Type
Private Function MakeTableStyleForSpec() As String
Dim acadDoc As Object
Dim AcadTableStyle As Object
Dim AcadTextStyle As Object
Dim AcadDictionary As Object
Dim strTableStyleName As String
Dim strTextStyleName As String
Set AcadDictionary = acadDoc.Dictionaries.Item("ACAD_TABLESTYLE")
strTableStyleName = "Оформление"
On Error Resume Next
Set AcadTableStyle = acadDoc.AcadDictionary.AddObject(strTableStyleName, "AcDbTableStyle")
strTextStyleName = "Оформление_текст"
Set AcadTextStyle = acadDoc.TextStyles.Add(strTextStyleName)
On Error GoTo 0
AcadTextStyle.SetFont "Arial", False, False, 0, 34 'значения получил по GetFont для нужного стиля
AcadTableStyle.SetTextStyle AcRowType.acDataRow + AcRowType.acHeaderRow + AcRowType.acTitleRow + AcRowType.acUnknownRow, strTextStyleName
AcadTableStyle.SetTextHeight AcRowType.acDataRow + AcRowType.acUnknownRow, 2.5
AcadTableStyle.SetTextHeight AcRowType.acHeaderRow + AcRowType.acTitleRow, 3
AcadTableStyle.SetAlignment AcRowType.acHeaderRow + AcRowType.acTitleRow, acMiddleCenter
AcadTableStyle.SetAlignment AcRowType.acDataRow + AcRowType.acUnknownRow, acMiddleLeft
AcadTableStyle.HorzCellMargin = 1.5
AcadTableStyle.VertCellMargin = 1
AcadTableStyle.SetGridLineWeight AcGridLineType.acHorzBottom + AcGridLineType.acHorzInside + AcGridLineType.acHorzTop _
+ AcGridLineType.acVertInside + AcGridLineType.acVertLeft + AcGridLineType.acVertRight, _
AcRowType.acTitleRow + AcRowType.acHeaderRow, AcLineWeight.acLnWt050
AcadTableStyle.SetGridLineWeight AcGridLineType.acHorzBottom + AcGridLineType.acHorzTop + _
AcGridLineType.acVertInside + AcGridLineType.acVertLeft + AcGridLineType.acVertRight, _
AcRowType.acDataRow + AcRowType.acUnknownRow, AcLineWeight.acLnWt050
AcadTableStyle.SetGridLineWeight AcGridLineType.acHorzInside, _
AcRowType.acDataRow + AcRowType.acUnknownRow, AcLineWeight.acLnWt025
Dim color As New AcadAcCmColor
color.SetRGB 255, 0, 0
AcadTableStyle.SetColor AcRowType.acDataRow + AcRowType.acHeaderRow _
+ AcRowType.acTitleRow + AcRowType.acUnknownRow, color
MakeTableStyleForSpec = strTableStyleName
End Function
Sub Tabl()
Dim acadApp As Object 'Объявляем переменные
Dim acadDoc As Object
Dim acadTable As Object
Dim LastRow As Long
Dim i As Long
Dim InsertionPoint(0 To 2) As Double
Dim value As String
Dim AcadTableStyle As Object
Dim AcadTextStyle As Object
Dim AcadDictionary As Object
Dim strTableStyleName As String
Dim strTextStyleName As String
With Sheets("Coordinates") 'Делаем активным лист координаты
.Activate
LastRow = .Cells(.Rows.Count, "AS").End(xlUp).Row 'Ищем последнюю заполненную строку столбца AS
End With
If LastRow < 4 Then 'Если номер последней строки меньше чем 4
MsgBox "Нет значений для вставки", vbCritical, "Ошибка отсутствие значений"
Exit Sub
End If
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application") 'Проверяем открыт ли автокад
If acadApp Is Nothing Then 'Если автокад не открыт
Set acadApp = CreateObject("AutoCAD.Application") 'Создаем новую сессию автокад
acadApp.Visible = True 'Делаем автокад видимым
End If
If acadApp Is Nothing Then 'Если опять автокад не открыт
MsgBox "Извините, но мы не можем запустить автокад", vbCritical, "Ошибка запуска автокад"
Exit Sub
End If
On Error GoTo 0 'Если ошибка то идем хз куда
On Error Resume Next 'Если ошибка то идем дальше
Set acadDoc = acadApp.ActiveDocument 'Присваиваем переменную активному чертежу автокада
If acadDoc Is Nothing Then 'Если ни один чертеж автокада не активен
Set acadDoc = acadApp.Documents.Add 'Создаем новый чертеж
End If
On Error GoTo 0 'Если ошибка то идем хз куда
If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding. Если чертеж открыт не в модели, а в листах
acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding. Делаем активной модель
End If
With Sheets("Coordinates") 'С листом Coordinates Excel
InsertionPoint(0) = .Range("AS" & 1).value 'Задаем координату X вставки блока
InsertionPoint(1) = .Range("AT" & 1).value 'Задаем координату Y вставки блока
InsertionPoint(2) = .Range("AU" & 1).value 'Задаем координату Z вставки блока
Set acadTable = acadDoc.ModelSpace.AddTable(InsertionPoint, 2, 5, 10, 20) 'Вставляем таблицу в чертеж
acadTable.RegenerateTableSuppressed = True
acadTable.DeleteRows 0, 1 'удаляем 1 строчку заголовка таблицы
acadTable.SetTextHeight 3, 3
acadTable.SetTextHeight 4, 3
acadTable.SetText 0, 0, .Range("AS" & 2).value
acadTable.SetColumnWidth 0, 15
acadTable.SetText 0, 1, .Range("AT" & 2).value
acadTable.SetColumnWidth 1, 70
acadTable.SetText 0, 2, .Range("AU" & 2).value
acadTable.SetColumnWidth 2, 50
acadTable.SetText 0, 3, .Range("AV" & 2).value
acadTable.SetColumnWidth 3, 40
acadTable.SetText 0, 4, .Range("AW" & 2).value
acadTable.SetColumnWidth 4, 30
'acadTable.RegenerateTableSuppressed = True
For i = 1 To LastRow - 3
acadTable.InsertRows i, 10, 1
acadTable.SetTextHeight 3, 3
acadTable.SetTextHeight 4, 3
'acadTable.RegenerateTableSuppressed = True
acadTable.SetText i, 0, .Range("AS" & i + 3).value
acadTable.SetText i, 1, .Range("AT" & i + 3).value
acadTable.SetText i, 2, .Range("AU" & i + 3).value
acadTable.SetText i, 3, .Range("AV" & i + 3).value
acadTable.SetText i, 4, .Range("AW" & i + 3).value
Next
acadTable.RegenerateTableSuppressed = False
acadTable.StyleName = MakeTableStyleForSpec
'acadTable.RegenerateTableSuppressed = True
End With ' Завершение взятия данных с листа эксель
acadApp.ZoomExtents ' Двойное нажатие на колесико мыши
Set acadDoc = Nothing ' ХЗ зачем обнуляем наверное перменные
Set acadApp = Nothing ' ХЗ зачем обнуляем наверное перменные
End Sub
