DWG.RU : Форум : Программирование

XAML. Создание всплывающих подсказок и дополнительной справки для команд

Автор: berstrider

Добавлено: 18 Jul 2026 20:25 (GMT + 4)

Подскажите пожалуйста, как при редактировании CUIX сделать путь к файлу XAML относительным. Что только не делал, а рабочий вариант - абсолютный путь. Очень неудобно для своей вкладки.

Как установить размеры рамки вокруг Мтекст?

Автор: ElectricSib

Добавлено: 17 Jul 2026 11:41 (GMT + 4)

Есть Мтекст с выравниванием середина по центру.
Возможно с помощью LISP задать точные размеры ограничивающей рамки вокруг него?
Почему-то нейросети не могут справиться этой задачей.

Как реализовать передачу списка состоящего из списков функции mapcar

Автор: vladimir777ak

Добавлено: 26 May 2026 22:35 (GMT + 4)

kp+ :
Можно поискать в другом интернете:
forums.autodesk.com/t5/visual-lisp-autolisp-and-general/list-sum-of-lists/m-p/11252118#M44093

Огромное спасибо капэплас, реализовал то что мне нужно:

Код:

(defun fn(fx lst)(apply(function mapcar)(cons(function fx)lst)))

(fn * (list(list 1 3 5 7)(list 4 6 8 0)))
(fn + (list(list 2 4 6 9)(list 1 3 5 7)(list 4 6 8 0)))
(fn vl-princ-to-string (list(list 2 4 6 9)))

Другого интернета у меня нету сам знаешь кому благодаря, да и поисковики нынче изрядно отупели - фильтруют все..

Notepad++ как альтернатива VLIDE (NPPVLIDE)

Автор: SetQ

Добавлено: 15 Apr 2026 05:52 (GMT + 4)

Подскажите, почему AcadLISPLauncher2.exe не может подключится к запущенному автокаду? AutoCAD 2022, VBA установлен, Windows 8.1.

Так же пытаюсь подключится на vbs командой

Код:

Set Acadobj = CreateObject("Autocad.Application")

или

Код:

Set acadApp = GetObject(, "AutoCAD.Application")

Выдаёт ошибку.

Неточная работа программы поиска неассоциативных размеров

Автор: Pilot

Добавлено: 14 Apr 2026 14:35 (GMT + 4)

Много лет периодически по мере надобности, в основном в чужих чертежах, пользовался этой программой (см. выше).
Еще раз спасибо VVA за доработанный, а фактически новый код. Все работает как было задумано!
Но пришло понимание, что неассоциативные размеры удобнее не просто выделять цветом, а переносить на отдельный слой.
В связи с этим наконец дошли руки это реализовать.
Сам тестировал только 1 день, пока ошибок не появлялось.

Код:

[LISP]
;;;; c:FDR Идея и первоначальный код - Михаил Сорокин.
;;;; Измененный код - VVA с форума dwg.ru.
;;;; Доработка интерфейса и перенос на слой вместо изм цвета - Pilot.

(defun c:Fdr ( / na n in l en lw obj Color layname)
(vl-load-com)
(setvar "cmdecho" 0)
(if (not (setq na (ssget "_x" '((0 . "DIMENSION")))))
(progn (setq na nil n nil in nil l nil en nil lw nil obj nil Color nil layname nil)
(alert "В чертеже нет размерных примитивов.")
(exit));progn
);if
(setq n (sslength na)
in 0
l 0
layname "_Dim_nonassociative" ;перенос на слой с этим именем
Color 6) ; и с этим цветом
(repeat n
(setq en (entget (setq obj (ssname na in))))
(if (and (/= (cdr (assoc 1 en)) "")
(not (TinT "<>" (cdr (assoc 1 en)))));and
(progn
(if (and (setq obj (vlax-ename->vla-object obj))
(vlax-write-enabled-p Obj)
(wcmatch (vla-get-Objectname Obj) "*Dimension*"));and
(progn
(command "_layer" "_n" layname "_c" Color layname "")
(vl-catch-all-apply 'vla-put-Layer (list Obj layname))
);progn
);if
(setq l (+ 1 l))
);progn
);if
(setq in (1+ in))
);repeat
(if (= l 0)
(alert "Неассоциативные размеры не найдены.")
(alert (strcat "Найдено неассоциативных размеров - " (rtos l 2 0))));if
(princ));c:Fdr

(defun TinT (t1 t2 / c1 v1);проверить t1 в t2
(if (= t2 0)(setq t2 nil)) ; не помню зачем эта проверка.
(if (and (= (type t1) 'STR)(= (type t2) 'STR)); - проверка что это литералы.
(progn
(setq t1 (strcase t1)
t2 (strcase t2)
c1 1)
(repeat (strlen t2)
(if (= t1 (substr t2 c1 (strlen t1)))(setq v1 c1))
(setq c1 (1+ c1)))
);progn
);if
v1);TinT
[/LISP]

Не загружаются приложения Ривилиса на AutoCAD 2025

Автор: Кулик Алексей aka kpblc

Добавлено: 02 Apr 2026 10:29 (GMT + 4)

С флудом завязываем.

GeomProps

Автор: serg48

Добавлено: 01 Apr 2026 23:20 (GMT + 4)

Всем привет.
До недавнего времени пользовался замечательнейшим GeomProps2019x64.arx в паре с AutoCAD 2020.
Заметил такую вещь, что теперь при выделении нескольких линий/заливок и тд. суммарная длина/площадь пишется 0, тоесть автокад перестал складывать длины и площади.
Скачал версию от 2026-04-01 14:40:34.
Может быть кто-то сталкивался и есть решение? Выгружал, заново добавлял расширение это - не вышло. Спасибо

Изменение свойств объектов внутри блока без его открытия - есть готовые бесплатные утилитки?

Автор: tigra-18

Добавлено: 26 Mar 2026 13:19 (GMT + 4)

Возникла потребность, быстро, в нескольких сотнях блоков заменить некоторые свойства(цвет, принадлежность слою) их содержимого. Есть ли бесплатные(потребность разовая) готовые утилиты которые могут это сделать?
Ну чтоб выбрать нужные блоки рамкой, задать новый слой(цвет) для их содержимого, нажать кнопочки для запуска операций и через несколько секунд/минут получить требуемый результат.

Групповой поиск и замена текста

Автор: znatok

Добавлено: 26 Feb 2026 09:42 (GMT + 4)

Цитата :
если еще актуально , то может это подойти
SRXTEXT - search/replace with regular expressions
(C) 2008, XANADU a.s. http://www.xanadu.cz
или эта : FindAndChange

нет возможности скачать требует какой-то регистрации

Как сделать автозапуск команды (или периодичность)

Автор: Admin

Добавлено: 11 Feb 2026 20:56 (GMT + 4)

forum.dwg.ru/announcement.php?f=13&a=21

Программное создание мультивыноски

Автор: Ingpro

Добавлено: 01 Feb 2026 17:36 (GMT + 4)

[COLOR="Silver"]Deleted[/COLOR]

Назначение набора параметров листа методами VBA

Автор: Theodor

Добавлено: 11 Jan 2026 20:39 (GMT + 4)

В пустоту для истории, но вдруг кто-то сюда попадёт в поисках ответа.

Dim strName as String
Dim objLay as AcadLayout
Dim vPlotConfig As AcadPlotConfiguration

Set objLay=ThisDrawing.Layouts.Item(0) ' тут выбор нужного листа, как объекта
strName="А3myPrinter" ' тут имя известного набора параметров (авторское)

For Each vPlotConfig In ThisDrawing.PlotConfigurations
If vPlotConfig.Name = strName Then
objLay.CopyFrom vPlotConfig 'установка типа печати, если есть похожий.
Exit For
End If
Next vPlotConfig

Где первоисточник программ Ривилиса?

Автор: Александр Ривилис

Добавлено: 04 Jan 2026 15:05 (GMT + 4)

ElectricSib :
Исходный код программ является секретом? или он тоже где-то выложен в открытом доступе.
Вопрос актуален после 2022 года.

Что-то я выкладывал на adn-cis.org, что-то было в качестве приложения к книге http://poleshchuk.spb.ru/cad/2006/Razr2006.htm
Что-то передавал по просьбе отдельных программистов, когда они пытались адаптировать их под клоны AutoCAD.

Как создать расчетное программное обеспечение с открытым исходным кодом (конструктивные решения)

Автор: Бахил

Добавлено: 03 Jan 2026 13:16 (GMT + 4)

А чем микрофе тебя не устраивает?

Лира-САПР. Как задать нагрузку через API

Автор: Timur_PGS

Добавлено: 11 Dec 2025 05:57 (GMT + 4)

Да. Документации ноль. Описание объектов в самой библиотеке минимальное. Там не нашел объектов, которые бы напоминали ввод нагрузки.
API для 2024 Лиры есть и работает, но возможно урезанный. Может в API 2025 Лиры и есть то что мне нужно.. Спасибо за наводку на 2025.

Автоматическая покраска деталей "ifc" модели по "guid" коду

Автор: Iluhensun

Добавлено: 10 Dec 2025 21:28 (GMT + 4)

Имеется 3D модель расширением "ifc". Также есть Excel файл деталей данной моделей, в котором есть колонка "guid" код. "guid" код - строчка из 20 случайных символов по которая дает уникальность каждому элементу, с помощью которой можно обращаться к любому элементу модели исключая вероятность задубления.

Мне нужно закрасить по "guid" коду 10 тысяч уникальных элементов в модели, а в модели 80 тысяч элементов. Пощелкивать через фильтр по "guid" коду, выделять каждый элемент очень долго.

Есть ли способы скрипты, программы, утилиты или онлайн сайты, желательно бесплатные. С помощью которых можно за несколько минут закрасить данные элементы

Вставка текста по координатам с помощью команды

Автор: Instauration

Добавлено: 30 Oct 2025 05:51 (GMT + 4)

Здравствуйте! Пытаюсь вставить текст в чертеж по координатам с помощью командной строки. Команду прописываю так:

"_TEXT 0,-15 2 0 какой-то текст" (координаты, размер, угол поворота, нужный текст)

Но после ее выполнения, текст в нужном месте чертежа не появляется, а появляется лишь место, в которое необходимо ввести текст вручную. Как это исправить?

VBA. Как восстановить формулу атрибута после замены на текст?

Автор: kp+

Добавлено: 28 Oct 2025 09:13 (GMT + 4)

Цитата :
Слэши "\" на двойные кавычки """" или на двойные слэши "\\"?

"\" на "\\". На лиспе точно сработало

Как создать и вызывать сочетанием клавиш плавающую панель по курсору

Автор: Сергей812

Добавлено: 27 Oct 2025 14:17 (GMT + 4)

можно и на WinForms сделать - несколько UserControl и подменять содержимое PaletteSet по требуемым критериям. В WPF просто с этим проще - из-за структуры вложенных контейнеров-контролов каждый визуальный контрол имеет свойство Visibilty и его (контрол) можно по отдельности скрыть/отобразить.

Python для AutoCAD реальность или утопия?

Автор: nickname2019

Добавлено: 23 Oct 2025 08:12 (GMT + 4)

У меня есть несколько старых процедур (им лет 20), при помощи которых я при помощи Delphi отрисовываю таблицы в автокад (там тоже COM, это древняя технология). Мне их влом переделывать, так как это трудоемко. С новыми автокадами эти процедуры не работают, поэтому я для них я держу старые версии автокада, в которых они работают замечательно. Для питона можно попробовать уменьшить версию автокада, чтобы убрать ошибки.
Хотя, может быть, проблема состоит в том, что новые версии автокада более активно используют многопоточность, что не дает корректно выводить данные через COM с использованием питона (при многопоточности нужно синхронизировать процессы при изменении переменных, не факт, что это делает COM).
Можно попробовать убрать многопоточность, установив переменную WHIPTHREAD в 0.

LISP. Как переписать код чтобы увеличить масштаб выдаваемого им текста?

Автор: Ingpro

Добавлено: 25 Sep 2025 17:52 (GMT + 4)

Цитата :
размер таблицы легко увеличивался, а размер текста оставался крошечным, а вот уже увеличить размер текста с помощью кода не выходило никак

Если таблица автокадовская, то при масштабировании всё увеличивается, в том числе и текст:

Код:

[LISP];; Функция, увеличивающая таблицу в 10 раз
(defun c:ScaleTable10 ( / ent scale)
(setq ent (car (entsel "Выберите таблицу: ")))
(if ent
(progn
;; коэффициент масштабирования
(setq scale 10.0) ; изменить на нужный
(setq inspt (cdr (assoc 10 (entget ent))))
(command "_.SCALE" ent "" inspt scale)
)
)
(princ)
)
[/LISP]

Выбрать таблицу и готово.
Можно прикрутить к основному коду.

Автокад 2023 макрос разделяющий один файл с листами на файлы с каждым листом

Автор: engngr

Добавлено: 26 Aug 2025 18:29 (GMT + 4)

поиск
+ forum.dwg.ru/showthread.php?t=146450
+"реверс" может быть

Где найти полный тестовый пример расчета для программы "Авторяд ЕС"?

Автор: Нубий-IV

Добавлено: 26 Aug 2025 09:49 (GMT + 4)

Если кто вживую видел ЭВМ ЕС (например, не я) - можно поностальгировать.
[LIST]
[*]Есть эмулятор старого железа Hercules:
https://github.com/SDL-Hercules-390/hyperion
[*]Есть эмулятор старых терминалов:
https://x3270.bgp.nu/
[*]Был сайт истории компьютеров it.museum-ic.ru. Сайт помер, но еще доступен в интернет-архиве. В его разделе загрузок была ссылка на образы софта под ЕС, она пока жива:
https://disk.yandex.ru/d/_vBDcqgNFjWTkw
[/LIST]
Как запустить:
[LIST]
[*]Качаем всех троих, распаковываем.
[*]Из софта для ЕС выбираем версию по вкусу - например, cbm401.zip, - распаковываем.
В папке CBM-R401 в файле конфигурации CBM2165.cnf подправляем пути к образам дисков/лент.
[*]Запускаем эмулятор с файлом конфигурации:

Код:

c:\Programs\Hercules\hercules.exe -f c:\Programs\Hercules.OS\CBM-R401\CBM2165.cnf

[*]Запускаем первый терминал wx3270.exe - он изображает оператора ВЦ.
Подключаемся к localhost:3270.
[*]В консоли эмулятора даем команду на загрузку с диска 240:
[MORE="Загрузка"][IMG]https://forum.dwg.ru/attachment.php?attachmentid=269241&stc=1&d=1756190500[/IMG][/MORE]
[*]В консоли оператора отвечаем на вопросы системы при загрузке:
[MORE="Оператор"][IMG]https://forum.dwg.ru/attachment.php?attachmentid=269242&stc=1&d=1756190500[/IMG][/MORE]
[*]Запускаем второй терминал wx3270.exe - он изображает пользователя.
Подключаемся к localhost:3270.Логинимся как SYSPRG/SYSPRG
[MORE="Пользователь"][IMG]https://forum.dwg.ru/attachment.php?attachmentid=269243&stc=1&d=1756190542[/IMG][/MORE]
[*]Что дальше - должен помнить пользователь ЭВМ ЕС.
Для остальных - руководства есть в интернете.
[/LIST]
Еще есть готовая сборка, но с оригинальной буржуйской системой MVS:
https://www.prince-webdesign.nl/index.php/software/mvs-3-8j-turnkey-5
[LIST]
[*]Распаковать
[*]Запустить mvs.bat, дождаться загрузки до логотипа
[*]Запустить wx3270.exe, подключиться к localhost:3270
[*]Залогиниться как HERC01/CUL8TR
[*]Дальше см. канал moshix.
Например, Fortran compilers on IBM MVS 3.8 (по нему я запускал старый фортран-IV, для сравнения с современным):
[/LIST]

Как открыть диалог Open или Save на VBA под AutoCAD

Автор: Artifed

Добавлено: 13 Aug 2025 09:04 (GMT + 4)

После поиска проблемы открытия диалоговых окон Save и Open, решил оставить часть кода на форуме, вдруг кому-то пригодится. Работает на Win11, Autocad 2024

Код:

Option Explicit

Private lngHwnd As LongPtr
Public strFilter As String
Public strTitle As String
Public strDir As String
Private blnHideReadOnly As Boolean
Private blnAllowMulti As Boolean
Private blnMustExist As Boolean
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXPLORER As Long = &H80000

Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As LongPtr
hInstance As LongPtr
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long 'LongPtr
lpfnHook As LongPtr
lpTemplateName As String
End Type

'------------------------------------------------------------

Public Function ShowOpen(ByVal strDir As String, ByVal strFilter As String, ByVal strTitle As String) As String

Dim strTemp As String
Dim udtStruct As OPENFILENAME

With udtStruct
.lStructSize = LenB(udtStruct)
'Use our private variable
.hwndOwner = lngHwnd
'Use our private variable
.lpstrFilter = strFilter
.lpstrFile = Space$(254)
.nMaxFile = 255
.lpstrFileTitle = Space$(254)
.nMaxFileTitle = 255
'Use our private variable
.lpstrInitialDir = strDir
'Use our private variable
.lpstrTitle = strTitle
' udtStruct.lpstrCustomFilter = "*.*"
'Ok, here we test our booleans to
'set the flag
End With

If blnHideReadOnly And blnAllowMulti And blnMustExist Then
udtStruct.flags = OFN_HIDEREADONLY Or _
OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_FILEMUSTEXIST
ElseIf blnHideReadOnly And blnAllowMulti Then
udtStruct.flags = OFN_ALLOWMULTISELECT _
Or OFN_EXPLORER Or OFN_HIDEREADONLY
ElseIf blnHideReadOnly And blnMustExist Then
udtStruct.flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST
ElseIf blnAllowMulti And blnMustExist Then
udtStruct.flags = OFN_ALLOWMULTISELECT Or _
OFN_EXPLORER Or OFN_FILEMUSTEXIST
ElseIf blnHideReadOnly Then
udtStruct.flags = OFN_HIDEREADONLY
ElseIf blnAllowMulti Then
udtStruct.flags = OFN_ALLOWMULTISELECT _
Or OFN_EXPLORER
ElseIf blnMustExist Then
udtStruct.flags = OFN_FILEMUSTEXIST
End If

If GetOpenFileName(udtStruct) Then
strTemp = (Trim(udtStruct.lpstrFile))
ShowOpen = Mid(strTemp, 1, Len(strTemp) - 1)
End If

End Function

Public Function ShowSave(ByVal strDir As String, ByVal strFilter, ByVal strTitle) As String

Dim strTemp As String
Dim udtStruct As OPENFILENAME
udtStruct.lStructSize = LenB(udtStruct)
'Use our private variable
udtStruct.hwndOwner = lngHwnd
'Use our private variable
udtStruct.lpstrFilter = strFilter
udtStruct.lpstrFile = Space$(254)
udtStruct.nMaxFile = 255
udtStruct.lpstrFileTitle = Space$(254)
udtStruct.nMaxFileTitle = 255
'Use our private variable
udtStruct.lpstrInitialDir = strDir
'Use our private variable
udtStruct.lpstrTitle = strTitle
If blnMustExist Then
udtStruct.flags = OFN_FILEMUSTEXIST
End If

If GetSaveFileName(udtStruct) Then
strTemp = (Trim(udtStruct.lpstrFile))
ShowSave = Mid(strTemp, 1, Len(strTemp) - 1)
End If

End Function

Public Sub Spec_Open()
Dim Filter As String
Dim InitialDir As String
Dim DialogTitle As String
Dim OutputStr As String
Dim Idcode As String

Filter = "Excel Workbook (*.xlsx)" + Chr$(0) + "*.xlsx" + Chr$(0) + _
"All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
InitialDir = "c:\"
DialogTitle = "Open a Settings file"
OutputStr = ShowOpen(InitialDir, Filter, DialogTitle)

If OutputStr = "" Then
MsgBox "Файл не выбран"
End If

MsgBox OutputStr

End Sub

Public Sub Spec_Save()
Dim Filter As String
Dim InitialDir As String
Dim DialogTitle As String
Dim OutputStr As String

'Set objFile = New FileDialogs
Filter = "Drawing Files (*.dwg)" + Chr$(0) + "*.dwg" + Chr$(0) + _
"All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
InitialDir = "c:\"
DialogTitle = "Save a Settings file"
OutputStr = ShowSave(InitialDir, Filter, DialogTitle)
MsgBox OutputStr
End Sub

Штриховка без площади

Автор: Sanmart

Добавлено: 07 Aug 2025 11:30 (GMT + 4)

Я часто работаю со штриховками с целью подсчёта площадей. Чтобы получить корректные данные, сначала обвожу замкнутыми полилиниями интересующие фрагменты, затем по этим полилиниям делаю штриховки и извлекаю данные. Так вот, если замкнутая полилиния пересекает саму себя, площадь штриховки не вычисляется. Есть ещё ряд ситуаций, когда площадь не отображается (например, если полилиния не замкнута). Чтобы избежать ошибок, я набросал в Excel'е макрос, который проверяет штриховки на нулевую площадь.

Программа очистки памяти автокад 2010 от притививов

Автор: ssn

Добавлено: 24 Jul 2025 15:36 (GMT + 4)

ну можно конечно попробовать. вставить как внешнюю ссылку и потом взорвать.
но сам по себе факт.. откуда это всё накатывает...

Преобразование текста и линий в мультивыноски (чохом)

Автор: ssn

Добавлено: 24 Jul 2025 11:31 (GMT + 4)

По моему запросу когда то писался вот такой лисп.
Что он делает.
В программе Автодеск Инвентор нет возможности настроить нормальные выноски в два этажа.
По этому, в автокаде приходилось править эти выноски. Выноски состояли из двух дуг, двух текстов и двух линий. Приложил картинку.
Лисп преобразует эти выноски в мультивыноску в два яруса. Работает пакетно. Мне очень помогает.
Понимаю, сам по себе лисп очень индивидуален, но возможно поможет понять, что и как делается

Код:

[LISP] ;******************************************************
;PSW - 2015 E-mail homepsw@gmail.com
;******************************************************
(defun C:PSW (/ A1 A2 CENTR DD DUGA ED EN I J KL LAY M1
M2 N N1 N2 NNN OBJ P1 P2 POINT RAD SLOY SS
SSSS T1 T2 TE1 TE2 U1 U2 W1 W2 OLD CEN DIS SER)
;******************************************************
(vl-load-com)
(setq Old (getvar "OsMode"))
(Setvar "CMDECHO" 0)
(setvar "CLAYER" "Обозначение (ISO)")
(prompt "\nВыберите рамкой объекты: ")
(setq SSSS (ssget))
(if (= SSSS Nil) (progn (alert "Нет дуг на слое <Обозначение (ISO)> для обработки выносок!") (exit))) ; если объектов нет завершаем работу
(setq NNN (sslength SSSS))
;*************************************************
(setvar "CLAYER" "Обозначение (ISO)") ; слой должен существовать
(setq j 0)
(setq KL 0)
(repeat NNN ; Цикл по всем выбранным дугам
(setq A1 (ssname SSSS j))
(setq j (+ 1 j))
(setq A2 (entget A1))
(setq Duga (cdr (assoc 0 A2))) ; дуга
(setq Sloy (cdr (assoc 8 A2))) ; дуга

(if (and (= DUGA "ARC") (= Sloy "Обозначение (ISO)") )
(progn
(setq Rad (cdr (assoc 40 A2))) ; Радиус
(setq Centr (cdr (assoc 10 A2))) ; центр дуги
(setq U1 (cdr (assoc 50 A2))) ; угол 1
(setq U2 (cdr (assoc 51 A2))) ; угол 2
(if (> U1 U2)
(progn
(setq W1 (polar Centr 3.92699 (* (sqrt 2.0) Rad)))
(setq W2 (polar Centr 0.785398 (* (sqrt 2.0) RAd)))
;(command "_LINE" (list 0.0 0.0 0.0) W2 "")
;(command "_ZOOM" "_ALL")
(setq SS (ssget "_C" W1 W2))
;;;;;;;;; (command "__rectang" W1 W2 )
;(command "_ZOOM" "О" SS "")
;(command "_REGEN" )
;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
(setq N (sslength SS))
(setq I 0)
(setq Te1 " ")
(setq Te2 " ")
(Repeat N
(setq EN (ssname SS I))
(setq ED (entget EN))
(setq Obj (cdr (assoc 0 ED)))
(setq LAY (cdr (assoc 8 ED)))
(setq Point (cdr (assoc 10 ED)))
;********************************************************
(if (= Obj "ARC")
(progn
(setq CEN (cdr (assoc 10 ED))) ; центр дуги
(setq SER (seredina W1 W2))
(setq Dis (distance Ser Point))
(setq Rad (cdr (assoc 40 ED))) ; Радиус

(if (< DIS RAD) (entdel en))
))
;********************************************************
(if (and (= Obj "LINE") (= LAY "Обозначение (ISO)")) (progn
(setq T1 (cdr (assoc 10 ED)))
(setq T2 (cdr (assoc 11 ED)))
(if ( = (cadr T1) (cadr T2)) (setq P1 T1 P2 T2))
(if (/= (cadr T1) (cadr T2)) (setq N1 T1 N2 T2))
(entdel en)
))
;********************************************************
(if (and (= Obj "MTEXT")(= LAY "Обозначение (ISO)") (> (cadr Point) (cadr Centr)))
(setq TE1 (cdr (assoc 1 ED))))
(if (and (= Obj "MTEXT")(= LAY "Обозначение (ISO)") (< (cadr Point) (cadr Centr)))
(setq TE2 (cdr (assoc 1 ED))))

(if (= Obj "MTEXT") (entdel en))
(setq i (+ i 1))
); REPEAT
;########################################################################
(setq dd 0.0)
(if (> (distance P1 N1) dd ) (setq dd (distance P1 N1) M1 N1 M2 P2))
(if (> (distance P2 N1) dd ) (setq dd (distance P2 N1) M1 N1 M2 P1))
(if (> (distance P1 N2) dd ) (setq dd (distance P1 N2) M1 N2 M2 P2))
(if (> (distance P2 N2) dd ) (setq dd (distance P1 N2) M1 N2 M2 P1))
(Setvar "OsMode" 0)
(command "_MLEADER" M1 M2 (strcat TE1 "\n" TE2) )
(setq b (vlax-ename->vla-object (entlast)))
(vlax-put-property b 'TextJustify 2)
(Setvar "OsMode" Old)

;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
;@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
)); if (> U1 U2)
))
); REPEAT NNN

(Setvar "OsMode" Old)
(SetVar "FILEDIA" 1) (princ)
) ; END DEFUN

;************************************************************************
; Функция возвращает: Точку середины отрезка Т1 Т2
; Параметр - точки Т1 Т2
;************************************************************************
(defun SEREDINA (TE1 TE2 / _AA _DX _DY _DZ)
(setq _DX (/ (+ (car TE1) (car TE2)) 2.0))
(setq _DY (/ (+ (cadr TE1) (cadr TE2)) 2.0))
(setq _DZ 0.0)
(if (and (/= (caddr TE1) NIL) (/= (caddr TE2) NIL))
(progn
(setq _DZ (/ (+ (caddr TE1) (caddr TE2)) 2.0))
)
)
(setq _AA (list _DX _DY _DZ))
) ;END DEFUN
;************************************************************************

[/LISP]

Создание одной команды, объединяющей несколько команд

Автор: Evleos

Добавлено: 02 Jul 2025 23:22 (GMT + 4)

Доброго времени суток.
Встала задача:
Необходимо спроецировать разные стороны 3D объекта на плоскость чертежа путем минимального количества действий.
Что-то вроде аналога ПЛОСКИЙ СНИМОК, но с учетом того, что спроецировать нужно одновременно несколько сторон.
Решение вроде бы найдено. Достигается следующим образом:
1)ИМПОРТ - импортирую файл stp на поле чертежа,
2)ВИДБАЗ - проецирую несколько видов на новый лист и этой же командой выбираю тип отображения (с внутренними линиями/без внутренних линий; масштаб и т.д.) создав необходимые типы видов
3)на новообразованном листе с этими видами применяю команду ЭКСПОРТВЭЛИСТА и сохраняю получившиеся виды отдельными блоками в новом файле.
Решил сделать макрос или команду чтобы реализовать все это одним действием, но в итоге получается создать лишь макрос путем ЗАПИСЬ который включает в себя лишь команду ВИДБАЗ.
Попытался реализовать это через команду которая включает 2 элемента: 1)полученный ЗАПИСЬю макрос 2)команда ЭКСПОРТВЭЛИСТА. Но ничего не выходит, макрос воспроизводится вторая команда нет, перепробовал элементы указанные в большинстве статей в интернете по типу \(ожидание ввода) ;(разделение команд) и др. но увязать все это ни как не могу.
Прошу подсказать как можно увязать ИМПОРТ затем макрос с ВИДБАЗ и ЭКСПОРТВЭЛИСТА в одной команде или в одном макросе.
См вложения.
(Для запуска макроса подойдет любой объект формата stp/step, для упрощения прилагаю произвольную step модель из открытого доступа)
(При запуске макроса в качестве объекта нажать на модель и ENTER)
Заранее спасибо.

Не обновляется файл acad.pgp 2014

Автор: Dima

Добавлено: 15 Jun 2025 16:19 (GMT + 4)

Кулик Алексей aka kpblc :
Насколько я помню, языковые пакеты и для АА существовали. Сейчас виртуалки с акадом запущенной нет, но вроде бы там можно найти acad.pgp:
(findfile "acad.pgp")
Может, ты правишь не тот файл ;) И я не помню, там в локализованных ACAD'ах была какая-то засада с командами.

я уже их все перепробовал, так же Express и встроенный в Архитектуру модуль редактирует эти файлы из программы. по ейже прописанным путям

Макрос. Расчленяет и очищает чертеж, работет выборочно, в чем проблема ?

Автор: tommy_69

Добавлено: 15 Jun 2025 15:03 (GMT + 4)

Доброго дня коллеги !

Написал макрос

^C^C_-LAYER;_LOCK;Lock;;_QAFLAGS;5;_explode;_all;;_explode;_all;;_ai_selall; МАСШТАБ 0,0 о;\\\_ai_selall;overkill;QAFLAGS;0;_-LAYER;_UNLOCK;Lock;;

- Блокируем слой "Lock"
- 2 раза расчленяем все объекты
- Масштабируем через опорный отрезок
- Очищаем повторения
- Разблокируем слой "Lock"

Задача: импортировать пдф, почистить и отмасштабировать для дальнейшей работы.

Проблема что работает не на всех чертежах, периодически пишет:

[COLOR="RoyalBlue"]Не находятся в текущем пространстве: 371.
Не могут быть расчленены: 425.
Выберите объекты:
Ничего не найдено.[/COLOR]

При этом, если вставить в тот же чертеж импорт из пдф, - начинает работать нормально, в чем может быть дело ?

Пробовал писать этот макрос через lisp, но когда при импорте пдф на черетеже оказывается порядка 100т объектов, автокад задумывается на очень долго

Для примера два файла, в одном макрос работает, в другом нет, и при вставки объектов из одно в другой, все работает :eek::eek::eek:

Пожалуйста помогите понять разницу :facepalm:

Автоматизация FLATSHOT и эмуляция нажатия клавиш

Автор: Nik1598

Добавлено: 03 Jun 2025 13:55 (GMT + 4)

AlexKniga :
learn.microsoft.com/ru-ru/windows/win32/wintouch/sendmessage--postmessage--and-related-functions

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

Sub Prob()

'проекция
ThisDrawing.Application.ZoomScaled 0.5, acZoomScaledRelative ' уменьшение масштаба, иначе косячит

Call Ent 'вызов нажатия enter
ThisDrawing.SendCommand ("_flatshot" & vbCr & "Р" & vbCr & "Да" & vbCr & "0,0,0" & vbCr & "1" & vbCr & "1" & vbCr & "0" & vbCr) & vbCr 'плоский снимок

End Sub

Sub Ent()

'нажатие enter для плоского снимка
SendKeys "{ENTER}"

End Sub

Передать в команду _updatefield набор примитивов (SelectionSets)

Автор: Автон

Добавлено: 21 Apr 2025 11:18 (GMT + 4)

Или не выходя из VBA

Код:

objSelSet.SelectOnScreen dxfCode, dxfValue ' выделяем объекты

ThisDrawing.SendCommand "(sssetfirst nil (ssget " & Chr(34) & "_P" & Chr(34) & ")) "

ThisDrawing.SendCommand "_updatefield" & vbCr

Набор для печати из шаблона

Автор: Serghei

Добавлено: 17 Apr 2025 16:20 (GMT + 4)

Может есть вариант без лиспа обойтись, через сценарий?
У меня такой сценарий, но он не закончен.
_psetupin
"j:\1.dwg"
A2
_-layout
_Set
Layout1

Далее мне нужно применить этот набор А2 к листу. Но как? Какой командой?

VBA. Как выделить ячейку таблицы?

Автор: МишаИнженер

Добавлено: 06 Apr 2025 09:33 (GMT + 4)

Метод GetEntity позволяет выбрать объект чертежа. Вот небольшая функция для работы с этим методом:

Код:

Public Function ПолучитьОбъектСЧертежа(objAcadDoc As AcadDocument, strСообщение As String, _
Optional bВнутрОбрОшибок As Boolean = False) As Variant
'Функция получает объект с чертежа и возвращает его в качестве ответа
Dim objОбъект As Object
Dim vНачТочка As Variant
If bВнутрОбрОшибок = True Then On Error Resume Next
ПолучитьОбъект:
Call ПоказатьAutoCAD(objAcadDoc)
Call objAcadDoc.Utility.GetEntity(objОбъект, vНачТочка, strСообщение)
If Err.Number <> 0 Then
Call ПоказатьExcel(objAcadDoc)
glОтвет = MsgBox("Продолжать выполнение программы?", vbYesNo, gsНазваниеПрограммы)
Err.Clear
If glОтвет = vbYes Then
GoTo ПолучитьОбъект
Else
End
End If
End If
Set ПолучитьОбъектСЧертежа = objОбъект
End Function

'Выделим таблицу
ВыделитьТаблицу:
Set Объект = ПолучитьОбъектСЧертежа(objAcadDoc, "Выдели таблицу:")
If Объект.ObjectName <> "AcDbTable" Then
glОтвет = MsgBox("Продолжать выделять таблицу?", vbYesNo)
If glОтвет = vbNo Then
End
End If
GoTo ВыделитьТаблицу
End If
Set objЯчейка = Объект

Когда надо выделить таблицу (указывать надо линии границ ячеек на чертеже) эта функция работает нормально.
А вот когда надо выделить ячейку таблицы (на чертеже выделяется текст ячейки) эта функция выдает ошибку.
Вообще я не нашел объекта ЯчейкаТаблицы (AcDbTableCell) и непонятно как на VBA выделять именно ячейку таблицы.
Мне надо сделать функцию отображающую линиями ссылки формулы выделенной ячейки на ячейки других таблиц.
Как мне в итоге получить доступ к интересующей меня ячейке?
При выделении ячейки возникает ошибка, а при выделении таблицы надо еще добраться до заданной ячейки.
Как выделить ячейку таблицы на VBA?

Помогите автоматизировать заполнение площади в атрибуте блока

Автор: Mita57

Добавлено: 17 Mar 2025 14:51 (GMT + 4)

Здравствуйте. У меня есть простой динамический блок «площадь» в Autocade, который создавался для подсчета площадей полилинии через «поля». Хотелось бы как-нибудь автоматизировать этот процесс, а именно:
Хотелось что бы при активации макроса, я мог выбрать нужную мне полилинию и автоматически бы вставился динамический блок «площадь» и в этом блоке бы заполнился атрибут «ПЛОЩАДЬ» через инструмент «поле» ( что бы если бы в дальнейшем изменились размеры полилинии то, площадь в блоке бы автоматически изменилась) и после запятой было бы 2 знака и значения бы были в метрах квадратных (умножены на коэф. 0.000001)
Сейчас все, что я описал выше делаю руками, а хотелось бы автоматизировать этот процесс. Chat gpt, что-то не может мне помочь. Помогите Вы, пожалуйста.

Мои макрокоманды

Автор: gumel

Добавлено: 16 Mar 2025 07:36 (GMT + 4)

Добрый день!
Делаю макрос, который позволяет сохранять выбранные объекты в DXF файл:

Код:

[LISP]^C^C+SAVEAS;F;R12;;O[/LISP]

Макрос вполне хорошо работает, за исключением пары моментов:
1. После выбора объектов команда спрашивает количество знаков после запятой "decimal places of accuracy". Как прописать это значение в макросе?
2. Приходится вводить имя файла :).

Нет ли такой возможности, чтобы имя файла бралось из примитива (допустим из обычного текста)?

Было бы прекрасно, когда пользователь выбирает объекты для экспорта в DXF, один из примитивов там будет текстом, и вот как раз значение этого текста будет именем файла.

Создание внешнего контура на основе выделенного набора примитивов

Автор: posetitel

Добавлено: 13 Mar 2025 15:51 (GMT + 4)

Подниму тему.
Уважаемый VAA, могли бы откорректировать код из сообщения #17 в части алгоритма поиска ближайшей точки. Сейчас, как я понял, сначала строится внешний прямоугольник, потом бегунок с указанным шагом проходит по этому прямоугольнику и ищет ближайшую точку на объекте. Хотелось бы, чтобы ближайшая точка находилась не по геометрическому расстоянию до выбранных примитивов, а чтобы от вертикальной грани внешнего прямоугольника проводилась горизонталь до примитивов и в месте пересечения образовывалась точка, а для горизонтальной грани внешнего прямоугольника опускалась (или соответственно поднималась) вертикаль до ближайшего из выбранных примитивов и в месте пересечения образовывалась точка, а потом эти точки соединялись в поверхность.
(на всякий случай прилагаю иллюстрацию: белая линия - это произвольный примитив, контур которого должен получиться, красным выделено то, какой контур должен получиться, зеленое - это линии внутри алгоритма, которые ищут ближайшие расстояния, голубой - это просто внешний контур)
Так, как сейчас работает алгоритм, на примитивах с уклоном и выступами по уклону программа часто рисует контур некорректно, Над выступом остается много неохваченных областей.

VBA. Как установить Мировую Систему Координат?

Автор: МишаИнженер

Добавлено: 13 Mar 2025 14:35 (GMT + 4)

Вот так работает:
ThisDrawing.SendCommand "_.ucs _w" & vbCr

Выравнивание полилинии в одну линию.

Автор: 1958

Добавлено: 13 Mar 2025 14:04 (GMT + 4)

Цитата :
Ещё одно поже6лание - возможность выбора начальной и конечной точек на исходной полилинии. Чтобы развертка рисовалась не для всей линии, а в заданном диапазоне.

Строго не судите, но что-то у меня получилось. :)
Правда выбираются только пересекаемые объекты. :(

Open DCL и перевод его на родной язык.

Автор: tujn08

Добавлено: 08 Mar 2025 18:32 (GMT + 4)

Подскажите как выполнить логику:
1) закрыть модальный диалог с даннымив таблице
2) выбрать новые данные
3) вернуть диалог и докинуть данные в таблицу?

п.3 не удается - в чем секрет не понятно.

Код:

[LISP]
(defun c:Untitled2/Dcl-2/TB2#OnClicked (/) ; добавить
(dcl-Form-Close Untitled2/Dcl-2)
(step1) ; обновление vl_list - выбор в чертеже
(dcl-Form-IsActive Untitled2/Dcl-2)
(dcl-Form-Show Untitled2/Dcl-2)
)
[/LISP]

диалог моргнул и всё. А если вручную вбить (dcl-Form-Show Untitled2/Dcl-2), то появляется с нужными данными.

подозрение, что внутри тела кнопки невозможно вывать диалог в котором эта кнопка.

похоже надо как и в DCL все завернуть в while и cond , а кнопками менять шаги.

Правильно мыслю же?