[AutoCAD] Экспорт координат в блоков в эксель

Sub ExtractDetailsOfAutoCADBlocks()
Open "C:\Users\n.olenev\Desktop\Script\Экспорт\123.txt" For Output As 1
 
Dim X, Y, Z As Double
Dim XLnCADObject As AcadObject
Dim XLnCADBlock As AcadBlockReference
Dim XLnCADSelection As AcadSelectionSet
MsgBox "Select Objects", , "XL n CAD"
 
On Error Resume Next
Set XLnCADSelection = ThisDrawing.SelectionSets.Add("XLnCAD_SelectionSet")
Set XLnCADSelection = ThisDrawing.SelectionSets("XLnCAD_SelectionSet")
XLnCADSelection.SelectOnScreen
 
For Each XLnCADObject In ThisDrawing.SelectionSets("XLnCAD_SelectionSet")
    If XLnCADObject.ObjectName = “AcDbBlockReference” Then
        Set XLnCADBlock = XLnCADObject
        X = XLnCADBlock.insertionPoint(0)
        Y = XLnCADBlock.insertionPoint(1)
        Z = XLnCADBlock.insertionPoint(2)
        Print #1, X; Y; Z; XLnCADObject.Name&; "; " & XLnCADBlock.Layer
    End If
Next
XLnCADSelection.Clear
 
Close (1)
End Sub

Sub ExtractDetailsOfAutoCADBlocks()
 
Dim FileXls: FileXls = "C:\Users\n.olenev\Desktop\Script\Экспорт\123.xlsx"
 
Dim XLnCADObject As AcadObject
Dim XLnCADBlock As AcadBlockReference
Dim XLnCADSelection As AcadSelectionSet
Dim i As Long
 
MsgBox "Select Objects", , "XL n CAD"
 
On Error Resume Next
Set XLnCADSelection = ThisDrawing.SelectionSets.Add("XLnCAD_SelectionSet")
Set XLnCADSelection = ThisDrawing.SelectionSets("XLnCAD_SelectionSet")
XLnCADSelection.SelectOnScreen
 
With CreateObject("Excel.Application")
    .Workbooks.Add
    .Visible = True
    .Application.ScreenUpdating = False
    .Application.DisplayAlerts = False
 
    i = 1
    For Each XLnCADObject In ThisDrawing.SelectionSets("XLnCAD_SelectionSet")
        If XLnCADObject.ObjectName = “AcDbBlockReference” Then
            Set XLnCADBlock = XLnCADObject
            .Cells(i, 1) = XLnCADBlock.insertionPoint(0)
            .Cells(i, 2) = XLnCADBlock.insertionPoint(1)
            .Cells(i, 3) = XLnCADBlock.insertionPoint(2)
            .Cells(i, 4) = XLnCADObject.Name&
            .Cells(i, 5) = "; " & XLnCADBlock.Layer
            
            i = i + 1
        End If
    Next
    XLnCADSelection.Clear
    
    .Columns("A:F").EntireColumn.AutoFit
    .Application.ScreenUpdating = True
    .ActiveWorkbook.SaveAs FileXls
    .Application.DisplayAlerts = True
End With
End Sub

Sub ExtractDetailsOfAutoCADBlocks()
 
Dim FileXls
FileXls = "C:\Users\n.olenev\Desktop\Script\Экспорт\123.xlsx"
 
Dim XLnCADBlock As AcadBlockReference
Dim XLnCADSelection As AcadSelectionSet
Dim i As Long
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
    FilterType(0) = 0
    FilterData(0) = "Insert"
 
MsgBox "Select Objects", , "XL n CAD"
 
For Each XLnCADSelection In ThisDrawing.SelectionSets
    If XLnCADSelection.Name = "XLnCAD_SelectionSet" Then
        XLnCADSelection.Delete
        Exit For
    End If
Next XLnCADSelection
Set XLnCADSelection = ThisDrawing.SelectionSets.Add("XLnCAD_SelectionSet")
XLnCADSelection.SelectOnScreen FilterType, FilterData
 
With CreateObject("Excel.Application")
    .Workbooks.Add
    .Visible = True
    .Application.ScreenUpdating = False
    .Application.DisplayAlerts = False
 
    i = 1
    For Each XLnCADBlock In ThisDrawing.SelectionSets("XLnCAD_SelectionSet")
                
            .Cells(i, 1) = XLnCADBlock.insertionPoint(0)
            .Cells(i, 2) = XLnCADBlock.insertionPoint(1)
            .Cells(i, 3) = XLnCADBlock.insertionPoint(2)
            .Cells(i, 4) = XLnCADBlock.EffectiveName
            .Cells(i, 5) = "; " & XLnCADBlock.Layer
         
            i = i + 1
        
    Next
    XLnCADSelection.Clear
    
    .Columns("A:F").EntireColumn.AutoFit
    .Application.ScreenUpdating = True
    .ActiveWorkbook.SaveAs FileXls
    .Application.DisplayAlerts = True
End With
XLnCADSelection.Delete
Set XLnCADSelection = Nothing
End Sub