(defun c:lispru-style-create-textstyle( / _lispru-style-create-textstyle adoc)
(defun _lispru-style-create-textstyle (doc coord lst / res)
;|
* Создание текстового стиля в документе
* Параметры вызова:
doc указатель на обрабатываемый документ (документ должен быть открыт)
coord имя создаваемого стиля
lst список дополнительных параметров вида:
'(("vert" . <Вертикальность стиля>)
("height" . <Фиксированная высота>) ; nil -> 15.0
("width" . <Коэффициент сжатия>) ; nil -> 1.0
("angle" . <Угол наклона, градусы>) ; nil -> 0.0
("back" . <Задом наперед>)
("down" . <Кверх ногами>)
("font" . <Используемый шрифт>) ; nil -> Arial
)
|;
(if (not doc)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
) ;_ end of if
;; Проверяем наличие текстового стиля
(if (not (setq res
(car
(member (strcase coord)
((lambda (/ _lst)
(vlax-for item (vla-get-textstyles doc)
(setq
_lst (cons (strcase (vla-get-name item)) _lst)
) ;_ end of setq
) ;_ end of vlax-for
_lst
) ;_ end of lambda
)
) ;_ end of member
) ;_ end of car
) ;_ end of setq
) ;_ end of not
(setq res (vla-add (vla-get-textstyles doc) coord))
) ;_ end of if
;; <...>
;;
res
) ;_ end of defun
(vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(_lispru-style-create-textstyle adoc '(("height" . 0.)))
(vla-endundomark adoc)
(princ))
И было бы неплохо указывать первоисточник кода ИМХО.
Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Настройки поиска (Страница 1 из 334)
Форумы CADUser → Сообщения от kpblc
Сообщений найдено с 1 по 25 из 8,348
1 20 февраля 2023г. 19:47:32
Re: Создание аннотированного стиля Lisp (1 ответов, оставленных в LISP)
2 11 августа 2016г. 23:04:04
Re: Помогите с программой (9 ответов, оставленных в LISP)
Возвращает список ассоциативных списков:
(defun test (/ _kpblc-conv-string-to-list file handle str lst)
(defun _kpblc-conv-string-to-list (string separator / i)
(cond ((= string "") nil)
((vl-string-search separator string)
((lambda (/ pos res)
(while (setq pos (vl-string-search separator string))
(setq res (cons (substr string 1 pos) res)
string (substr string (+ (strlen separator) 1 pos))
) ;_ end of setq
) ;_ end of while
(reverse (cons string res))
) ;_ end of lambda
)
)
((wcmatch (strcase string) (strcat "*" (strcase separator) "*"))
((lambda (/ pos res _str prev)
(setq pos 1
prev 1
_str (substr string pos)
) ;_ end of setq
(while (<= pos (1+ (- (strlen string) (strlen separator))))
(if (wcmatch (strcase (substr string pos (strlen separator))) (strcase separator))
(setq res (cons (substr string 1 (1- pos)) res)
string (substr string (+ (strlen separator) pos))
pos 0
) ;_ end of setq
) ;_ end of if
(setq pos (1+ pos))
) ;_ end of while
(if (< (strlen string) (strlen separator))
(setq res (cons string res))
) ;_ end of if
(if (or (not res) (= _str string))
(setq res (list string))
(reverse res)
) ;_ end of if
) ;_ end of lambda
)
)
(t (list string))
) ;_ end of cond
) ;_ end of defun
(if (and (setq file (getfiled "File" "" "sdr" 4)) (/= file ""))
(progn (setq handle (open file "r"))
(while (setq str (read-line handle))
(if (wcmatch (strcase str) "08TP*,08KI*")
(setq lst (cons str lst))
) ;_ end of if
) ;_ end of while
(close handle)
(mapcar (function
(lambda (x)
(mapcar (function cons) '("name" "x" "y" "descr") (cdr (_kpblc-conv-string-to-list x " ")))
) ;_ end of lambda
) ;_ end of function
lst
) ;_ end of mapcar
) ;_ end of progn
) ;_ end of if
) ;_ end of defunТо же, список списков:
(defun test2 (/ _kpblc-conv-string-to-list file handle str lst)
(defun _kpblc-conv-string-to-list (string separator / i)
(cond ((= string "") nil)
((vl-string-search separator string)
((lambda (/ pos res)
(while (setq pos (vl-string-search separator string))
(setq res (cons (substr string 1 pos) res)
string (substr string (+ (strlen separator) 1 pos))
) ;_ end of setq
) ;_ end of while
(reverse (cons string res))
) ;_ end of lambda
)
)
((wcmatch (strcase string) (strcat "*" (strcase separator) "*"))
((lambda (/ pos res _str prev)
(setq pos 1
prev 1
_str (substr string pos)
) ;_ end of setq
(while (<= pos (1+ (- (strlen string) (strlen separator))))
(if (wcmatch (strcase (substr string pos (strlen separator))) (strcase separator))
(setq res (cons (substr string 1 (1- pos)) res)
string (substr string (+ (strlen separator) pos))
pos 0
) ;_ end of setq
) ;_ end of if
(setq pos (1+ pos))
) ;_ end of while
(if (< (strlen string) (strlen separator))
(setq res (cons string res))
) ;_ end of if
(if (or (not res) (= _str string))
(setq res (list string))
(reverse res)
) ;_ end of if
) ;_ end of lambda
)
)
(t (list string))
) ;_ end of cond
) ;_ end of defun
(if (and (setq file (getfiled "File" "" "sdr" 4)) (/= file ""))
(progn (setq handle (open file "r"))
(while (setq str (read-line handle))
(if (wcmatch (strcase str) "08TP*,08KI*")
(setq lst (cons str lst))
) ;_ end of if
) ;_ end of while
(close handle)
(mapcar (function (lambda (x) (cdr (_kpblc-conv-string-to-list x " ")))) lst)
) ;_ end of progn
) ;_ end of if
) ;_ end of defun3 27 июля 2015г. 09:05:14
Re: Ошибка: неверный тип аргумента: stringp nil (5 ответов, оставленных в LISP)
Сначала запусти функцию min-dist-orosit
4 2 июля 2015г. 23:02:23
Re: Как определить радиус в полилинии LISPом (13 ответов, оставленных в LISP)
На фига так? Получить через (entsel) указатель на примитив и координаты точки, высчитать ближайшую к примитиву, получить значение параметра, округлить до целого и по параметру получить координаты вершины (это предыдущая вершина), добавить 1 к параметру и получить координаты вершины (это следующая вершина), через vla-getbundle получить значение кривизны - и все. Никаких дополнительных построений, разбиваний и отмен.
5 2 июля 2015г. 13:45:40
Re: Как определить радиус в полилинии LISPом (13 ответов, оставленных в LISP)
6 23 мая 2015г. 00:40:08
Re: Пакетная обработка чертежей лисп программой в Window7 сильно тормозит в сравнении с ХР (2 ответов, оставленных в LISP)
в чем может быть проблема
99% - в коде.
8 12 января 2015г. 23:51:54
Re: overkill (12 ответов, оставленных в LISP)
Посмотри свойства отрезков в твоем чертеже: у одного она снизу слева, у второго - сверху справа.
P.S. Сейчас к рабочей машине не подключиться (2013 только на ней есть), а так - я снимал обе галочки, касающихся Co-linear objects
9 12 января 2015г. 22:12:01
Re: overkill (12 ответов, оставленных в LISP)
Поиграйся с опциями overkill'a. Особенно с настройками коллинеарных объектов.
У тебя отрезки разнонаправленные, поэтому подобное поведение и возникает.
10 12 января 2015г. 15:58:23
Re: overkill (12 ответов, оставленных в LISP)
На яндекс-диск, например. Ссылку сюда.
P.S. Не факт, что смогу достучаться до экзотических файлообменников.
11 12 января 2015г. 13:27:39
Re: overkill (12 ответов, оставленных в LISP)
Повторить не удалось. ACAD2013x64Eng + SP
12 12 января 2015г. 10:30:43
Re: overkill (12 ответов, оставленных в LISP)
Ни фига не понял. Хоть бы картинки какие-то...
Ортогональные - ок. А что значит "Расстояние между ними"? А это отрезки или полилинии? А они точно в одной плоскости рисовались? У них точно одна и та же ОСК? А что значит "offset внутрь"? А SP, кстати, на AutoCAD установлен?
13 16 декабря 2014г. 14:53:59
Re: Как программно определить имя файла внешней ссылки? (5 ответов, оставленных в LISP)
В любом случае код впрямую использовать нельзя: не контролируется тип выбираемого примитива, не проверяется "а вообще это ссылка или нет", не преобразовывается возможный относительный путь в абсолютный и т.п.
Но это уже отдельная песня...
14 16 декабря 2014г. 14:20:15
Re: Как программно определить имя файла внешней ссылки? (5 ответов, оставленных в LISP)
vl-filename-base возвращает только имя файла, но не полный путь. Хотя, если это и требовалось - то бога ради ))
15 16 декабря 2014г. 12:47:24
Re: Как программно определить имя файла внешней ссылки? (5 ответов, оставленных в LISP)
(defun get-xref-filename (/ ent err)
(if (and (setq ent (car (entsel)))
(setq ent (vlax-ename->vla-object ent))
(vlax-property-available-p ent 'path)
) ;_ end of and
(if (vl-catch-all-error-p
(setq err
(vl-catch-all-apply
(function
(lambda ()
(princ
(strcat
"\nPath by ent : "
(vla-get-path ent)
"\nPath by BLOCKDEF : "
(vla-get-path
(vla-item
(vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)) (vla-get-effectivename ent))
) ;_ end of vla-item
) ;_ end of vla-get-path
) ;_ end of strcat
) ;_ end of princ
) ;_ end of lambda
) ;_ end of function
) ;_ end of vl-catch-all-apply
) ;_ end of setq
) ;_ end of vl-catch-all-error-p
(princ (strcat "\nERROR : " (vl-catch-all-error-message err)))
) ;_ end of if
) ;_ end of if
(princ)
) ;_ end of defun16 15 декабря 2014г. 12:36:31
Re: Экспорт координат точек с номерацией в файл Excel, + алгоритм обработки (платно) (2 ответов, оставленных в LISP)
Два года времени и по 50 000 рублей ежемесячно.
17 9 ноября 2014г. 21:04:12
Re: Помогите исправить ошибку в коде (4 ответов, оставленных в LISP)
А кто может гарантировать, что в наборе будет именно 2 точки?
P.S. Знаменитые грабли тебя не миновали :)
http://autolisp.ru/2013/12/19/command-e … -troubles/
http://forum.dwg.ru/showpost.php?p=2711 … tcount=167
18 9 ноября 2014г. 16:46:45
Re: Помогите исправить ошибку в коде (4 ответов, оставленных в LISP)
Лучше задавать вопросы на adn-cis.org : там форум поживее будет :)
Тем не менее, как вариант (я понимаю, что использовать вариант привязки "между 2 точками не катит) для простановки "между двумя точками"
(defun c:sp1 (/ pt1 pt2 pt)
(if (and (= (type (setq pt1 (vl-catch-all-apply
(function
(lambda ()
(ssget "_+.:S:E" '((0 . "POINT")))
) ;_ end of lambda
) ;_ end of function
) ;_ end of vl-catch-all-apply
) ;_ end of setq
) ;_ end of type
'pickset
) ;_ end of =
(setq pt1 (cdr (assoc 10 (entget (ssname pt1 0)))))
(= (type (setq pt2 (vl-catch-all-apply
(function
(lambda ()
(ssget "_+.:S:E" '((0 . "POINT")))
) ;_ end of lambda
) ;_ end of function
) ;_ end of vl-catch-all-apply
) ;_ end of setq
) ;_ end of type
'pickset
) ;_ end of =
(setq pt2 (cdr (assoc 10 (entget (ssname pt2 0)))))
) ;_ end of and
(entmakex (list (cons 0 "POINT")
(cons 10
(mapcar
(function
(lambda (a b)
(* (+ a b) 0.5)
) ;_ end of lambda
) ;_ end of function
pt1
pt2
) ;_ end of mapcar
) ;_ end of cons
(cons 8 "2 Точки центра опор")
) ;_ end of list
) ;_ end of entmakex
) ;_ end of if
) ;_ end of defunЕсли нужна фильтрация по расстояниям, то это уже совсем другая песня.
19 5 октября 2014г. 20:57:01
Re: Работа с ApplicationPlagins (3 ответов, оставленных в LISP)
А что там "сдаваться"? Там люди вежливые, не кусаются ;)
20 8 августа 2014г. 14:58:52
Re: ObjectARX. Получение/изменение из AutoLisp свойств чертежа (Summary Info) (56 ответов, оставленных в Готовые программы)
Я по запарке не в ту сторону слеши поставил - смотри измененный вариант. Это раз.
Второе. Что за путь к чертежу? Это который (getvar "dwgprefix")? А какой он будет у несохраненного файла dwg?
Дмитрий Эль, функция setdwgprops работает вполне корректно. Если ошибка - то ошибка в передаваемых параметрах. Их и проверяй.
21 8 августа 2014г. 14:36:56
Re: ObjectARX. Получение/изменение из AutoLisp свойств чертежа (Summary Info) (56 ответов, оставленных в Готовые программы)
Как говорится, "почувствуй разницу"
(setdwgprops '(("Title" "Тестовый чертеж") ("Subject" "Чертеж (\"Название\")") ("Параметр" "а это его значение")) T)22 6 августа 2014г. 23:40:55
Re: Работа AutoCAD с регистром Windows. (3 ответов, оставленных в LISP)
Вроде бы это уже где-то обсуждалось... Для работы своего приложения совсем необязательно использовать ветки реестра AutoCAD'a, мне кажется.
23 6 августа 2014г. 14:35:21
Re: Работа AutoCAD с регистром Windows. (3 ответов, оставленных в LISP)
Так вопрос о работе AutoCAD'a или LISP'a?
24 21 июля 2014г. 21:43:47
Re: Восстановление параметров по умолчанию. (4 ответов, оставленных в LISP)
Стоп, предлагаю разделить: информация, касающаяся работы AutoCAD - отдельно. Касающаяся работы приложения / дополнения - отдельно. В ветке HKEY_CURRENT_USER\Software\Autodesk\AutoCAD\RXX.X\ACAD-YYYY:ZZZ можно добавить до дури всякой информации, но AutoCAD ее не увидит. А при работе приложения / дополнения вносить туда изменения можно в любой момент.
Я к чему: создать свою ветку в реестре, куда все необходимое и записывать. И все...
25 21 июля 2014г. 18:11:26
Re: Восстановление параметров по умолчанию. (4 ответов, оставленных в LISP)
А кто мешает писать в другие ветки реестра?
Сообщений найдено с 1 по 25 из 8,348
Форумы CADUser → Сообщения от kpblc
Форум работает на PunBB, при поддержке Informer Technologies, Inc
