Правильный вызов Excel из AutoCAD, чтобы дальше можно было работать с Excel

'      SendMessage hWnd, WM_USER + 18, 0, 0

Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End
End With
End Sub

........
'в наборе будут вхождения блоков с нужными атрибутами
sset.Select acSelectionSetAll, , , fT, fD
     Dim xlApp As Excel.Application
     Set xlApp = Nothing
     Dim xlBook As Workbook
     Dim xlSheet As Worksheet
     On Error Resume Next
     Err.Clear
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
          Err.Clear
          Set xlApp = CreateObject("Excel.Application")
          If Err <> 0 Then
               MsgBox "Cannot start Excel", vbExclamation
               End
          End If
     End If
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
xlApp.Visible = True
Cells(1, 1).Value = "Номер"
Cells(...).Value = "..."
...
Dim atts As Variant 'для атрибутов
For i = 0 To sset.Count - 1
    atts = sset(i).GetAttributes
    Cells(i + 2, 1).Value = atts(0).TextString
    Cells(...).Value = atts(...).TextString
...
Next i
'далее выбор и сортировка
Dim myRan As Excel.Range
Set myRan = Range("A2", Cells(sset.Count + 1, 5))
myRan.Sort Cells(2, 1)
Set myRan = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End
End With
End Sub

Public Sub AttExtract()
With ThisDrawing
[i][b]'определим набор для необходимых вхождений блоков.[/i][/b]
Dim sset As AcadSelectionSet
DeclareSSet sset, "4attsset" [i]'это моя фунцкия для перебора и удаления существующего имени и записи в SelectionSets. просто облегчает жизнь и уж точно работает )) [/i]
[i]'далее описывается механизм выбора и фильтрации, принципиально к имеющимся проблемам не относится.
'создаем механизм фильтрации для набора. нужные вхождения характеризуются символами "_NB" в конце имени. переберем коллекцию чертежа Blocks, одновременно создавая механизм фильтрации по нужным именам.[/i]
Dim BlColl As AcadBlocks
Set BlColl = .Blocks
Dim Blk As AcadBlock
Dim fT() As Integer    [i]'FilterType[/i]
Dim fD() As Variant    [i]'FilterData[/i]
Dim i As Integer
i = 2                  [i]'для размеров дин.массивов. '2', потому что первые сейчас определим ->[/i]
ReDim fT(1): ReDim fD(1)
fT(0) = 0:  fD(0) = "INSERT"    [i]'по вхождениям блоков[/i]
fT(1) = -4: fD(1) = "<or"       [i]'отрываем логическое "ИЛИ" для разных имен[/i]
For Each Blk In BlColl
    If GetLastName(Blk.Name) = "NB" Then [i]'GetLastName моя функция, как раз достает из входящей строки символы после последнего '_'. если '_' вообще нет в строке, то возвращает "".[/i]
        ReDim Preserve fT(i + 1): ReDim Preserve fD(i + 1)
        fT(i) = 2: fD(i) = Blk.Name
        fT(i + 1) = -4: fD(i + 1) = "or>"
        i = i + 1
    End If
Next
[i][b]'теперь есть необходимый фильтр - выберем по всему чертежу то, что нужно[/i][/b]
sset.Select acSelectionSetAll, , , fT, fD
If sset.Count = 0 Then
    GoTo NoBlRef  [i]'в конец программы[/i]
End If
[i][b]'теперь нужно выводить атрибуты вхождений из набора в Excel.[/i][/b]
[i]'Начинается самое интересное ).[/i]
     Dim xlApp As Excel.Application
     Set xlApp = Nothing
     Dim xlBook As Workbook
     Dim xlSheet As Worksheet
     On Error Resume Next
     Err.Clear
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
          Err.Clear
          Set xlApp = CreateObject("Excel.Application")
          If Err <> 0 Then
               MsgBox "Cannot start Excel", vbExclamation
               End
          End If
     End If
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
xlApp.Visible = True
With xlSheet
[i][b]'Обозначим столбцы[/b]
'Один столбец пропущен для спец.символов номеров, потом удалим после сортировки[/i]
.Cells(1, 1).Value = "Номер кабеля"
.Cells(1, 3).Value = "Тип кабеля"
.Cells(1, 4).Value = "Длина кабеля"
.Cells(1, 5).Value = "Начало"
.Cells(1, 6).Value = "Конец"
[i]'определим Range для форматирования последующей сортировки[/i]
Dim myRan As Excel.Range
Set myRan = .Range("A2", .Cells(sset.Count + 1, 6))
myRan.NumberFormat = "@"    [i]'текстовый[/i]
Dim atts As Variant   [i]'для атрибутов[/i]
Dim sNum As String    [i]'для строки номера[/i]
Dim sRNum As String   [i]'для начальной "цифренной" части номера[/i]
Dim sDopNum As String [i]'для дополнительной "символьной" части номера[/i]
For i = 0 To sset.Count - 1   [i]'пройдемся по набору[/i]
    atts = sset(i).GetAttributes    [i]'достаем атрибуты[/i]
    sNum = atts(0).TextString
    sRNum = IsNum(sNum)   [i]'фунуция IsNum из строки возвращает Long из первых цифренных символов строки, если только текст, возвращает Long=0[/i]
    If sRNum = "0" Then  [i]'тогда это просто текст[/i]
        sRNum = sNum
        sDopNum = ""     [i]'и символьная часть не нужна[/i]
    Else
        sDopNum = Right(sNum, Len(sNum) - Len(sRNum))  [i]'отделили символьную часть номера[/i]
    End If
[i][b]'запись в ячейки[/i] [/b]
    .Cells(i + 2, 1).Value = sRNum      [i]'номер кабеля "реальный"[/i]
    .Cells(i + 2, 2).Value = sDopNum    [i]'символьная часть номера[/i]
    .Cells(i + 2, 3).Value = sset(i).Layer     [i]'тип кабеля[/i]
    .Cells(i + 2, 4).Value = CInt(atts(1).TextString)    [i]'длина кабеля[/i]
    .Cells(i + 2, 5).Value = atts(2).TextString          [i]'начало[/i]
    .Cells(i + 2, 6).Value = atts(3).TextString          [i]'конец[/i]
Next i
[i][b]'сортируем [/b] во-первых по номеру, во-вторых по "символьным" частям[/i]
myRan.Sort Key1:=.Cells(2, 1), Key2:=.Cells(2, 2), DataOption1:=xlSortTextAsNumbers
[i]'объединим номер с принадлежащей ему "символьной" частью[/i]
For i = 1 To sset.Count + 1
    sNum = .Cells(i, 1).Value + .Cells(i, 2).Value
    .Cells(i, 1).Value = sNum
Next
'удалим теперь вспомогательный столбец для символьных частей
.Columns(2).Delete
End With
Set myRan = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End
NoBlRef:
MsgBox "Нет засечек кабелей"
Exit Sub
End With
End Sub