Option Explicit
Private Type ScaleFactor
X As Double
Y As Double
Z As Double
End Type
Sub InsertBlocks()
Dim acadApp As Object
Dim height As Double
Dim acadDoc As Object
Dim acadBlock As Object
Dim attributeObj As Object
Dim LastRow As Long
Dim i As Long
Dim InsertionPoint(0 To 2) As Double
Dim BlockName As String
Dim BlockScale As ScaleFactor
Dim RotationAngle As Double
Dim tag As String
Dim value As String
Dim prompt As String
Dim varAttributes As Variant
Dim varBlockProperties As Variant
Dim Index As Variant
Dim prop As Variant
Dim propatr As Variant
'Activate the coordinates sheet and find the last row.
With Sheets("Coordinates")
.Activate
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Check if there are coordinates for at least one circle.
If LastRow < 2 Then
MsgBox "There are no coordinates for the insertion point!", vbCritical, "Insertion Point Error"
Exit Sub
End If
'Check if AutoCAD application is open. If is not opened create a new instance and make it visible.
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If acadApp Is Nothing Then
Set acadApp = CreateObject("AutoCAD.Application")
acadApp.Visible = True
End If
'Check (again) if there is an AutoCAD object.
If acadApp Is Nothing Then
MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
Exit Sub
End If
On Error GoTo 0
'If there is no active drawing create a new one.
On Error Resume Next
Set acadDoc = acadApp.ActiveDocument
If acadDoc Is Nothing Then
Set acadDoc = acadApp.Documents.Add
End If
On Error GoTo 0
'Check if the active space is paper space and change it to model space.
If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding
End If
'On Error Resume Next ' -- здесь комментируем
'Loop through all the rows and add the corresponding blocks in AutoCAD.
With Sheets("Coordinates")
For i = 2 To LastRow
'Задаем имя блока
BlockName = .Range("A" & i).value
'Вставляем блок если он есть
If BlockName <> vbNullString Then
'Задаем координаты вставки блока
InsertionPoint(0) = .Range("B" & i).value
InsertionPoint(1) = .Range("C" & i).value
InsertionPoint(2) = .Range("D" & i).value
'Задаем геометрию блока
BlockScale.X = .Range("E" & i).value
BlockScale.Y = .Range("F" & i).value
BlockScale.Z = .Range("G" & i).value
'Задаем Поворот блока
RotationAngle = 0
Set attributeObj = acadBlock.AddAttribute(height, prompt, InsertionPoint, tag, value) ' ошибка №1
Set acadBlock = acadDoc.ModelSpace.InsertBlock(InsertionPoint, BlockName, BlockScale.X, BlockScale.Y, BlockScale.Z, RotationAngle * 0.0174532925)
End If
varAttributes = acadBlock.GetAttributes
varAttributes(0).TextString = .Range("L" & i).value
varAttributes(1).TextString = .Range("M" & i).value
varAttributes(2).TextString = .Range("N" & i).value ' ошибка №2
varAttributes(3).TextString = .Range("O" & i).value ' ошибка №3
varAttributes(4).TextString = .Range("P" & i).value ' ошибка №4
varAttributes(5).TextString = .Range("Q" & i).value ' ошибка №5
'varAttributes(6).TextString = .Range("L" & i).value
'varAttributes(7).TextString = .Range("M" & i).value
acadBlock.Layer = .Range("K" & i).value
If acadBlock.IsDynamicBlock = True Then
varBlockProperties = acadBlock.GetDynamicBlockProperties
For Index = LBound(varBlockProperties) To UBound(varBlockProperties)
Set prop = varBlockProperties(Index)
If prop = prop.PropertyName = "Ширина" Then ' ошибка №6
prop.value = .Range("H" & i).value
ElseIf prop = prop.PropertyName = "Длина" Then ' ошибка №7
prop.value = .Range("Длина" & i).value
End If
acadBlock.Layer = .Range("K" & i).value ' это нафига в цикле, плюс это дубль
Next
End If
'varBlockProperties.Update
Next i
End With
'Zoom in to the drawing area.
acadApp.ZoomExtents
'Release the objects.
Set acadBlock = Nothing
Set acadDoc = Nothing
Set acadApp = Nothing
End Sub
