[acad_newbie]

добрый вечер! подскажите как можно текст из Autocad закинуть в excel по строкам одного столбца? на чертеже множество текстовых объектов (чисел) (около 6000), z=0.

[Кулик Алексей aka kpblc]

Версия AutoCAD? Лично я подобную задачу решал бы лиспом, но тут раздел другой.

[Arystan]

в свое время мне помог _dataextraction

[KennyMckormik]

как то озадачивался этим вопросом вот названия ПО, что нарыл:

tablebuilder
ToolPac (http://www.dotsoft.com/toolpac.htm)
http://dwg.ru/dnl/8901
MechanicsCS

что-то еще было, но вспомнить не получается

может поможет

[AlexV]

VBA макрос. Выбирает объекты "Текст", "МТекст", вставляет в excel файл в один столбец..

[johny100]

Сообщение от AlexV VBA макрос. Выбирает объекты "Текст", "МТекст", вставляет в excel файл в один столбец..

Прошу прощения, а подскажите как активировать команду после загрузки данного макроса ?

[v.psk]

johny100, очевидно есть разные варианты, самый простой (наверное) - в редакторе нажать "run"

[Leshqa]

Сообщение от AlexV VBA макрос. Выбирает объекты "Текст", "МТекст", вставляет в excel файл в один столбец..

Здравствуйте!
По описанию как раз то, что я и искал, очень здравая вещь, но как он работает может быть есть гайд какой-то?
При запуске макроса, я выделяю объекты и всё что он делает - пишет количество текстовых файлов.

В буфер обмена ничего не кладёт.
Подскажите, как, всё таки, эту информацию переправить в эксель с помощью данного макроса?

[aspid132]

В VetCAD есть текстовый редактор, через который можно выбрать несколько текстовых объектов для редактирования, потом скопировать их из редактора и вставить в excel. Объекты вставляются в excel в один столбец

----- добавлено через ~5 мин. -----

Сообщение от Leshqa Здравствуйте! По описанию как раз то, что я и искал, очень здравая вещь, но как он работает может быть есть гайд какой-то? При запуске макроса, я выделяю объекты и всё что он делает - пишет количество текстовых файлов. В буфер обмена ничего не кладёт. Подскажите, как, всё таки, эту информацию переправить в эксель с помощью данного макроса?

У меня этот макрос работает, если запущен какой-нибудь файл excel (именно файл, а не запущенный сеанс excel с несохраненной "Книгой 1") . Тогда создается новый файл с текстовым массивом из AutoCAD.

[Cfytrr]

C сайта акада:
Преобразуйте текстовые объекты в один объект Mtext, войдя в командную строку TXT2MTXT и выделив текстовые объекты.
Для таблицы ограничьте столбцы запятыми.
Дважды щелкните объект MText и скопируйте текст (Ctrl + C)
Теперь запустите Microsoft Excel и вставьте данные в одну ячейку. Весь текст должен быть вставлен в одну ячейку.
Выделите ячейку с текстом, затем перейдите на вкладку «Данные» и нажмите «Текст в столбцы».
Появится окно под названием Мастер преобразования текста в столбцы.
На первой странице выберите С разделителями и нажмите Далее
На второй странице задайте разделители. выберите "Запятая" и нажмите Далее
Нажмите кнопку Готово!

[igor_klim]

Сообщение от AlexV VBA макрос. Выбирает объекты "Текст", "МТекст", вставляет в excel файл в один столбец..

так в чём же все таки проблема? Пишет только количество текстовых файлов, а в эксель не копирует.
Сохраненный файл экселя открыт. Пробовал экселевский файл сохранять и с расширением xls и xslm и xlsx ничего не помогает.

[Dinoxromniy]

Сообщение от igor_klim так в чём же все таки проблема?

Укажите версии и разрядность офиса и акада.

Сообщение от igor_klim Сохраненный файл экселя открыт.

Код должен создавать свой новый файл.

Сообщение от igor_klim а в эксель не копирует.

Рискну предположить, что эксель запускается в фоновом режиме и вы его просто не видите. Попробуйте добавить в явном виде отображение экселя, код должен быть таким:

Код:

[Выделить все]

Option Explicit
Sub main()
Dim acSelSet As AcadSelectionSet, txt_obj As AcadEntity, txtarr(), i As Long
Dim objSelectionSet As AcadSelectionSet
Dim strPromt    As String ' запрос у пользователя
Dim strKeys     As String
Dim strReply    As String

strPromt = "Выбрать объекты [Все объекты / выБрать рамкой](Все объекты):"
strKeys = "В Б"
ThisDrawing.Utility.Prompt (vbCrLf)
Call ThisDrawing.Utility.InitializeUserInput(0, strKeys)
strReply = ThisDrawing.Utility.GetKeyword(strPromt)
If strReply = "" Then strReply = "В"
Set acSelSet = SelectOnlyOnScreen(strReply)
If acSelSet.Count = 0 Then
  ThisDrawing.Utility.Prompt ("Текст в чертеже отсутствует..")
  End
End If
ReDim txtarr(0 To acSelSet.Count - 1)
i = 0
For Each txt_obj In acSelSet
 txtarr(i) = txt_obj.TextString
 i = i + 1
Next
Dim Excel As Object
On Error Resume Next
'Вызов приложения
Set Excel = GetObject(, "Excel.Application")
If Err <> 0 Then
 Err.Clear
 Set Excel = CreateObject("Excel.Application")
 If Err <> 0 Then
  MsgBox "Нельзя загрузить Excel.", vbExclamation
  End
 End If
End If
Excel.Application.Visible = True
Excel.Application.Workbooks.Add
Excel.range("A1:A" & i).Value = Excel.Application.WorksheetFunction.Transpose(txtarr)
MsgBox i & " текстовых объектов"

End Sub
Private Function SelectOnlyOnScreen(str) As AcadSelectionSet
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Dim intType(3) As Integer
Dim varData(3) As Variant
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
 If objSelSet.Name = "Blck" Then
  objSelSet.Delete
  Exit For
 End If
Next
Set objSelSet = ThisDrawing.SelectionSets.Add("Blck")
intType(0) = -4
varData(0) = "<OR"
intType(1) = 0
varData(1) = "TEXT"
intType(2) = 0
varData(2) = "MTEXT"
intType(3) = -4
varData(3) = "OR>"
If str <> "В" Then
  objSelSet.SelectOnScreen intType, varData
Else
  objSelSet.Select acSelectionSetAll, , , intType, varData
End If
Set SelectOnlyOnScreen = objSelSet
End Function

[AlexV]

Сообщение от igor_klim так в чём же все таки проблема? Пишет только количество текстовых файлов, а в эксель не копирует. Сохраненный файл экселя открыт. Пробовал экселевский файл сохранять и с расширением xls и xslm и xlsx ничего не помогает.

Качнул свой макрос. На удивление, несмотря на 13 лет, прошедших с момента выкладывания, работает. Записал видос, в архиве приложен.
Создается новый файл и в него копируется текст, а не в открытый активный. Если при первом запуске макроса эксель не был запущен, то возможно, запускается "невидимкой", поэтому "в эксель не копирует". Можно либо через диспетчер задач посмотреть и убить все процессы экселя, потом открыть эксель, потом запустить макрос.
Ну, или как Dinoxromniy советует, отрихтовать код, "...Visible = True" добавить..

[igor_klim]

Сообщение от Dinoxromniy Рискну предположить, что эксель запускается в фоновом режиме и вы его просто не видите.

Всё верно. Запускался эксель в фоновом режиме. Потом только увидел что более 20 раз мой текст копировался в новые листы экселя.
Обнаружил это когда нашел Lisp для подобной задачи. Он то мне и запустил все мои фоновые окна.
Лисп нашел здесь https://www.cadstudio.cz/freeware
называется Txt2XLS

[igor_klim]

Сообщение от Dinoxromniy Попробуйте добавить в явном виде отображение экселя, код должен быть таким:

Спасибо большое! Теперь не надо даже зпускать Эксель, ни до внедрения кода, ни после. Он сам загружается когда выделишь текст в акаде.
Но вот теперь другой вопрос: В автокаде тексты стояли в столбик в одном порядке а в экселе совсем в другом (в разброс). Как сделать чтобы в экселе они выстраивались в том же порядке?

[AlexV]

Сообщение от igor_klim Спасибо большое! Теперь не надо даже зпускать Эксель, ни до внедрения кода, ни после. Он сам загружается когда выделишь текст в акаде. Но вот теперь другой вопрос: В автокаде тексты стояли в столбик в одном порядке а в экселе совсем в другом (в разброс). Как сделать чтобы в экселе они выстраивались в том же порядке?

Внести в код изменения. К примеру, снимать с объектов текст/мтекст координаты, заносить вместе со значениям текста в динамический массив, потом сортировать массив по значению координат, потом уже собрать строку для экселя..

[kp+]

Сообщение от igor_klim Как сделать чтобы в экселе они выстраивались в том же порядке?

https://dwg.ru/dnl/14892

[Dinoxromniy]

Сообщение от igor_klim В автокаде тексты стояли в столбик в одном порядке а в экселе совсем в другом (в разброс)

Если выделять рамкой за один раз, то в набор они попадут в четком обратном порядке, не в разнобой.
Соответственно, можно либо вручную написать формулу в экселе, чтобы реверсировать порядок,

либо допустим вывести через код VBA в столбце В значения в обратном порядке.
Повторюсь - важно выделять текст единственным выделением рамки, либо же учитывать, что при нескольких выделениях рамкой каждое выделение попадет в обратном порядке.

Код:

[Выделить все]

Sub main()
Dim acSelSet As AcadSelectionSet, txt_obj As AcadEntity, txtarr(), i As Long
Dim objSelectionSet As AcadSelectionSet
Dim strPromt    As String ' запрос у пользователя
Dim strKeys     As String
Dim strReply    As String

strPromt = "Выбрать объекты [Все объекты / выБрать рамкой](Все объекты):"
strKeys = "В Б"
ThisDrawing.Utility.prompt (vbCrLf)
Call ThisDrawing.Utility.InitializeUserInput(0, strKeys)
strReply = ThisDrawing.Utility.GetKeyword(strPromt)
If strReply = "" Then strReply = "В"
Set acSelSet = SelectOnlyOnScreen(strReply)
If acSelSet.count = 0 Then
  ThisDrawing.Utility.prompt ("Текст в чертеже отсутствует..")
  End
End If
ReDim txtarr(0 To acSelSet.count - 1)
i = 0
For Each txt_obj In acSelSet
 txtarr(i) = txt_obj.textString
 i = i + 1
Next
Dim Excel As Object
On Error Resume Next
'Вызов приложения
Set Excel = GetObject(, "Excel.Application")
If Err <> 0 Then
 Err.Clear
 Set Excel = CreateObject("Excel.Application")
 If Err <> 0 Then
  MsgBox "Нельзя загрузить Excel.", vbExclamation
  End
 End If
End If
Excel.Application.Visible = True
Excel.Application.Workbooks.Add
Dim j As Integer, k As Integer
For j = 1 To i
Excel.Range("B" & j).value = txtarr(i - k - 1)
k = k + 1
Next j
Excel.Range("A1:A" & i).value = Excel.Application.WorksheetFunction.Transpose(txtarr)
MsgBox i & " текстовых объектов"

End Sub
Private Function SelectOnlyOnScreen(str) As AcadSelectionSet
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Dim intType(3) As Integer
Dim varData(3) As Variant
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
 If objSelSet.Name = "Blck" Then
  objSelSet.Delete
  Exit For
 End If
Next
Set objSelSet = ThisDrawing.SelectionSets.Add("Blck")
intType(0) = -4
varData(0) = "<OR"
intType(1) = 0
varData(1) = "TEXT"
intType(2) = 0
varData(2) = "MTEXT"
intType(3) = -4
varData(3) = "OR>"
If str <> "В" Then
  objSelSet.SelectOnScreen intType, varData
Else
  objSelSet.Select acSelectionSetAll, , , intType, varData
End If
Set SelectOnlyOnScreen = objSelSet
End Function

[v.psk]

в экселе можно и просто сортировку

[kp+]

Сообщение от Dinoxromniy Если выделять рамкой за один раз, то в набор они попадут в четком обратном порядке, не в разнобой

Это если выделять по одному. Если "массовым" методом (window, crossing window, polygon, crossing polygon, fence, или при выборе всех сразу) - то в порядке создания текстовых объектов, который не всегда такой, как хотелось бы. Поэтому только сортировка по Y-координате, только хардкор
Впрочем, все уже написано, см.приложение по ссылке из #17.