Вставка блока в отделный слой.

Option Explicit
' request check on 'Break on Unhadled Errors' radio button
' in Tools->Options->General->Error Trapping field
' uses Frank Oquendo's technic
Public Function LayerExists(layerName As String) As Boolean

Dim layer As AcadLayer

On Error Resume Next
Set layer = ThisDrawing.Layers(layerName)
LayerExists = (Err.Number = 0)

End Function

Public Function BlockExists(blkName As String) As Boolean

Dim blk As AcadBlock

On Error Resume Next
Set blk = ThisDrawing.Blocks(blkName)
BlockExists = (Err.Number = 0)

End Function

Public Function MakeLayer(layName As String, lType As String, _
                          intColor As Integer, enumLW As Integer)

     Dim oLayers As AcadLayers
     Dim oLayer As AcadLayer

     On Error GoTo Err_Handler

     Set oLayers = ThisDrawing.Layers
     For Each oLayer In oLayers
          If oLayer.name = layName Then
               GoTo Exit_Here
          End If
     Next

     Set oLayer = ThisDrawing.Layers.Add(layName)
     Dim acColor As New AcadAcCmColor
     acColor.ColorMethod = AutoCAD.acColorMethodByACI
     acColor.ColorIndex = intColor
     
     If intColor = acByLayer Then
          MsgBox "This color index is" & vbNewLine & _
                 "not valid for Layer object"
          GoTo Exit_Here
     End If

     oLayer.TrueColor = acColor
     oLayer.Linetype = lType
     oLayer.Lineweight = enumLW

Exit_Here:
     Exit Function

Err_Handler:
     MsgBox (Err.Number & Chr(9) & Err.Description)
End Function

Public Sub InsertBlock()

Dim oSpace As AcadBlock
Dim insPnt(0 To 2) As Double
Dim varPnt1 As Variant
Dim varPnt2 As Variant
Dim dblAng, dblScale As Double
Dim blkName As String
Dim layerName As String
Dim ccl As String
Dim curLay As AcadLayer
Dim newLay As AcadLayer
Dim blkRef As AcadBlockReference

On Error GoTo Err_Control

With ThisDrawing
'//
If .ActiveSpace = acModelSpace Then
Set oSpace = .ModelSpace
Else
Set oSpace = .PaperSpace
End If
ccl = .GetVariable("CECOLOR")

Set curLay = .ActiveLayer

blkName = InputBox("Enter block name:", "Block Name Question")

If Not BlockExists(blkName) Then Exit Sub

layerName = InputBox("Enter layer name or" & vbNewLine & _
"press Enter to default layer", "Layer Name Question", "0")
'//==
If Not LayerExists(layerName) Then
Call MakeLayer(layerName, "Continuous", 7, acLnWtByLwDefault) '<---change layer settings here
End If
' check again
If LayerExists(layerName) Then
.ActiveLayer = .Layers(layerName)
Else
MsgBox "Problem with creating the layer"
Exit Sub
End If
'//==
dblScale = CDbl(InputBox("Enter block scale or" & vbNewLine & _
"press Enter to default scale", "Block Scale Question", 1))

With .Utility
'//**
varPnt1 = .GetPoint(, "Pick insertion point of block")

varPnt2 = .GetPoint(varPnt1, _
"Pick point to define rotation")

dblAng = .AngleFromXAxis(varPnt1, varPnt2)
insPnt(0) = varPnt1(0): insPnt(1) = varPnt1(1): insPnt(2) = varPnt1(2)
'//**
End With
.SetVariable "CECOLOR", "BYLAYER"
Set blkRef = oSpace.InsertBlock(insPnt, blkName, dblScale, dblScale, dblScale, dblAng)
.ActiveLayer = curLay
.SetVariable "CECOLOR", ccl
.Regen acActiveViewport
'//
End With

Exit_Here:
Exit Sub

Err_Control:
On Error Resume Next
If Err.Number <> 0 Then
MsgBox Err.Description
End If
Resume Exit_Here

End Sub