Sub InsertBlocksFromExcel()
Dim AP As Excel.Application
Dim WB As Excel.Workbook
Dim ws As Excel.Worksheet
Dim ar(50) As Integer
Dim n As Integer
Dim blockRef As AcadBlockReference
Dim name As String
Dim insertPoint(0 To 2) As Double
Set AP = Excel.Application
Set WB = AP.Workbooks.Open("c:\Users\evthi\Desktop\Тестовый эксель.xlsx")
Set ws = WB.Worksheets("Лист1")
n = 0
'Пробегаемся по всем строчкам таблицы
For i = 3 To 31
'Если 1й и 2й столбцы пустые то в массив записываем номер следующей строки
'это и будет строчка с нашими марками
If Cells(i, 1) = "" And Cells(i, 2) = "" Then
ar(n) = i + 1
n = n + 1
End If
Next
'Пробегаемся по нашему массиву, в котором лежат номера строк марок
For i = LBound(ar) To n
insertPoint(0) = CDbl(Cells(ar(i), 3))
insertPoint(1) = CDbl(Cells(ar(i), 4))
insertPoint(2) = CDbl(Cells(ar(i), 5))
name = Cells(ar(i), 2)
'Пробегаемся по всем экземплярам
For j = ar(i) + 1 To ar(i + 1) - 2
On Error GoTo ES:
'Вставляем блок
Set blockRef = ThisDrawing.ModelSpace.InsertBlock(insertPoint, "Тестовый", 1, 1, 1, 0)
insertPoint(0) = insertPoint(0) + 1000#
'Работа с динамическими свойствами
If blockRef.IsDynamicBlock = True Then
Props = blockRef.GetDynamicBlockProperties
For Index = LBound(Props) To UBound(Props)
Set prop = Props(Index)
If prop.PropertyName = "Расстояние1" Then
prop.Value = Cells(j, 1) * 1
End If
Next
End If
'Работа с атрибутами
If blockRef.HasAttributes = True Then
att = blockRef.GetAttributes
For Index = LBound(att) To UBound(att)
If att(Index).TagString = "МАРКА" Then
att(Index).TextString = name
End If
Next
End If
Next
Next
'В случае ошибки попадаем сюда
ES:
AP.Quit
End Sub
