LISP. Фрагмент чертежа по прямоуг. или кругл. границе (Страница 2 из 5)

Денис Флюстиков

Денис Флюстиков
Активный участник

На форуме с 12 октября 2005г.
Сообщений: 374
Спасибо: 10

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

skkkk пишет:

Спасибо, Денис! Потестировал и обнаружил такую вещь: Если в копируемый фрагмент попадают поля (field), то они теряют связь со своим объектом, превращаясь в нечто вроде "############". При обычном копировании такого не происходит. Реально с этим что-либо сделать?
Больше к чему придраться не нашел - все супер
Поправлюсь: поля слетают вроде только те, что расположены внутри мультивыносок. В таблицах и текстах остаются
Поправлюсь2: хотя нет, некоторые мультивыноски остались, а тексты слетели (поля в смысле). Закономерность неясна.

skkkk, большая просьба выслать мне на fd-@mail.ru DWG-файлик с полями (field) и с границами для фрагментов, посмотрю, что можно сделать.

Да, "Fragm_Den" от 20.05.09 чуть подправил и в 23.00 заменил код в сообщении "20.05.2009 19:07:57"

kheylan

kheylan
Участник

Откуда: Свердловская / Екатеринбург
На форуме с 1 апреля 2008г.
Сообщений: 18
Спасибо: 0

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Команда замечательная.
Но, есть пожелания,чтобы атрибуты блока при создания фрагмента конвертировались в текст. Например, использовать команду Burst из Express. Или еще лучше, чтобы блок обрезался подобно в команде Clipit из того же Express

Денис Флюстиков

Денис Флюстиков
Активный участник

На форуме с 12 октября 2005г.
Сообщений: 374
Спасибо: 10

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Спасибо за отзывы и предложения по улучшению программы.
[quote=Цитата

skkkk]
....
Если в копируемый фрагмент попадают поля (field), то они теряют связь со своим объектом, превращаясь в нечто вроде "############". При обычном копировании такого не происходит. Реально с этим что-либо сделать?
Больше к чему придраться не нашел - все супер

Поправлюсь: поля слетают вроде только те, что расположены внутри мультивыносок. В таблицах и текстах остаются
Поправлюсь2: хотя нет, некоторые мультивыноски остались, а тексты слетели (поля в смысле). Закономерность неясна.

skkkk, большая просьба выслать мне на fd-@mail.ru DWG-файлик с полями (field) и с границами для фрагментов, посмотрю, что можно сделать.

skkkk, получил твой файл, но, похоже, для корректной работы с полями необходимо полностью менять алгоритм программы (перевод FIELDEVAL в «0» во время выполнения программы дает временный эффект). Может, есть более простой метод без глобальных изменений и местные ГУРУ дадут совет. Надеюсь на помощь.

Александр пишет:

.....
Но, есть пожелания,чтобы атрибуты блока при создания фрагмента конвертировались в текст. Например, использовать команду Burst из Express. Или еще лучше, чтобы блок обрезался подобно в команде Clipit из того же Express

Александр, насчет атрибутов сейчас тоже без помощи не обойтись. Думаю воспользоваться проверенным кодом из Burst.LSP, сам все равно лучше не придумаю. Постараюсь данную корректировку сделать в ближайшее время.
Если не нужно расчленять все блоки в заданной области, а только на указанной границе, то нужно заменить строчку:
(setq aa3 (ssget "_CP" aa1 '((0 . "INSERT"))))
на:
(setq aa3 (ssget "_F" aa1 '((0 . "INSERT"))))

Денис Флюстиков

Денис Флюстиков
Активный участник

На форуме с 12 октября 2005г.
Сообщений: 374
Спасибо: 10

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Александр пишет:

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

;|====================================================
Фрагмент чертежа по прямоуг.,кругл. или ломаной границе
(программа тестировалась на AutoCAD 2006, 2008, 2009)

Программа Дениса Флюстикова "Fragm_Den" от 25.05.09:
Работа с атрибутами

Макрос для кнопки:
^C^C^P(load "Fragm_Den");Fragm_Den

Замечания и предложения по адресу fd-@mail.ru
====================================================|; 

(defun c:Fragm_Den (/ *error* aa1 aa2 aa3 aa4 aa5 aa6 aa7 aa8 aa9
            aa10 aa11 aa12 aa13 aa14 aa15)

(if (>= (atof (getvar "ACADVER")) 16.2)(progn

(initget 128 "К Л")

(setq aa10 "Размер" ;Слой построения контура
      aa8 (ssadd)
      aa2 nil
      aa5 nil
      aa1 (getpoint "\nПервая точка прямоугольной области или [Круглая/Ломаная]:"))

(vl-load-com)

(cond
((= (type aa1) 'LIST)
   (if (setq aa2 (getcorner aa1 "\nВторая точка области:"))(progn
(setq aa1 (trans aa1 1 0)
      aa2 (trans aa2 1 0)
      aa7 (list (cons 10 aa1)
      (cons 10 (list (car aa1)(cadr aa2)))
      (cons 10 aa2)
      (cons 10 (list (car aa2)(cadr aa1))))
)
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")

)
))
((= aa1 "К")

(initget 1)
(setq aa1 (getpoint "\nЦентр круглой области:"))

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")
(if aa10 (if (tblsearch "Layer" aa10)(setvar "CLAYER" aa10)))

(princ "\nРадиус области:")

(vl-cmdf "_.circle" aa1)
(while (= (getvar 'cmdactive) 1)
(setq aa2 (vl-cmdf pause)))

(if aa2 (progn
(setq aa2 (cadr (grread 1 1))
      aa2 (trans aa2 1 0)
      aa4 (entlast)
      aa3 (vlax-ename->vla-object aa4)
      aa5 (vlax-curve-getEndParam aa3)
      aa5 (vlax-curve-getDistAtParam aa3 aa5)
      aa5 (/ aa5 256.0)
      aa1 0
      aa7 '())

(repeat 256
(setq aa7 (append aa7 (list (cons 10 (vlax-curve-getpointatdist aa3 aa1))))
      aa1 (+ aa1 aa5))
)

)))
(T

(setq aa1 (getpoint "\nПервая точка ломаной границы или <Выбрать>:"))

(if aa1 (progn

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")

(princ "\nСледующая точка границы:")

(if (vl-cmdf "_.line" aa1 pause)(progn

(setq aa1 (list aa1))
(princ "\nСледующая точка границы или <Прервать>:")

(while (= (getvar 'cmdactive) 1)
(setq aa3 (getvar "lastpoint")
      aa7 (car aa1)
      aa6 aa1
      aa1 (cons aa3 aa1)
      aa8 (ssadd (entlast) aa8))

(if (equal (last aa1) aa3 1e-6)
(vl-cmdf "")(progn

(while (> (length aa6) 2)
(setq aa6 (cdr aa6))
(if (or (inters aa3 aa7 (car aa6)(cadr aa6) t)
    (equal (angle aa3 aa7)(angle (caddr aa1) aa7) 1e-6)
    (equal aa3 aa7 1e-6))(progn
(vl-cmdf "_u")
(princ "\nСамопересечение границы\nСледующая точка границы или <Прервать>:")
(setq aa1 (cdr aa1)
      aa6 nil)))
)
(setq aa3 (vl-cmdf pause))
))
)
))

(if (and aa3 (> (length aa1) 2))
(setq aa2 (trans (getvar "lastpoint") 1 0)
      aa7 '())(progn
(setq aa2 nil)
(command "_.undo" "_b")
))

(mapcar '(lambda (q) (setq aa7 (append aa7 (list (cons 10 (trans q 1 0)))))) aa1)
)(progn

(setq aa1 (entsel "\nВыберите полилинию типа LWPOLYLINE состоящую из линейных сегментов или <Выход>:" ))

(if aa1 (progn

(setq aa2 (trans (cadr aa1) 1 0)
      aa4 (car aa1)
      aa5 (entget aa4)
      aa7 '())

(if (= (cdr (assoc 0 aa5)) "LWPOLYLINE")(progn

(mapcar '(lambda (q) (if (= (car q) 10)(setq aa7 (append aa7 (list q)))
               (if (= (car q) 42)
             (if (/= (cdr q) 0)
               (setq aa2 nil)
               )))) aa5)
(if aa2
(if (< (length aa7) 3)(progn
(setq aa2 nil)
(princ "\nВыбранная полилиния имеет меньше трех вершин")
))
(princ "\nВыбранная полилиния имеет дуговой сегмент"))
)(progn
(setq aa2 nil)
(princ "\nВыбранный объект не является легкой полилинией (примитив типа LWPOLYLINE)")
))
))

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")

))
)
)

(if aa2 (progn

(defun *error* (msg)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(if (< (atof (getvar "ACADVER")) 17.1)
(vla-sendcommand (vla-get-activedocument
(vlax-get-acad-object)) "_.undo 1 ")
(command nil nil nil nil "_.undo" 1))
(princ "\nВыход во время обработки данных\n")
)

(if aa10 (if (tblsearch "Layer" aa10)(setvar "CLAYER" aa10)))

(setq aa3 (list (cons 0 "LWPOLYLINE")(cons 100 "AcDbEntity")(cons 100 "AcDbPolyline"))
      aa7 (append (list (cons 90 (length aa7))(cons 70 1)) aa7)
      aa1 '())

(entmake (append aa3 aa7))

(mapcar '(lambda (q)

(if (= (car q) 10)
(setq aa1 (cons (trans (cdr q) 0 1) aa1)))

) aa7)

(if aa5
(setq aa8 (ssadd (entlast) aa8))
(setq aa4 (entlast))
)

(setvar "OSMODE" 0)
(setvar "LTSCALE" 0.0001)

(command "_.shademode" 2
     "_.zoom" "_o" (entlast) ""
     "_.offset" (/ (getvar "VIEWSIZE") 2e4)(entlast)(getvar "VSMAX") ""
     "_.zoom" "_o" (setq aa5 (entlast) aa6 aa5) "")

(setvar "EXPLMODE" 1)

(while aa3
 ; Блоки расчленить: "_CP" - все в выбранной области, "_F" - на границе:
(setq aa3 (ssget "_F" aa1 '((0 . "INSERT")))
      aa9 aa6)

(if aa3
(repeat (setq aa7 (sslength aa3))

(setq aa10 (ssname aa3 (setq aa7 (1- aa7)))
      aa11 (entget aa10)
      aa12 aa10
      aa13 '())

(if (= (cdr (assoc 66 aa11)) 1)(progn

;;;(command "_.attsync" "_s" aa10 "_y")

(while (/= "SEQEND" (cdr (assoc 0 aa11)))

(if (= (cdr (assoc 0 aa11)) "ATTRIB")(progn

(setq aa14 '())

(foreach aa15 '(2 1 7 8 10 11 39 40 41 50 51 62 71 73)(progn
(if (/= (assoc aa15 aa11) nil)
(setq aa14 (append aa14 (list (assoc aa15 aa11)))))))

(setq aa13 (cons aa14 aa13))

))

(setq aa12 (entnext aa12)
      aa11 (entget aa12))

)
))

(command "_.explode" aa10)

(while (entnext aa9)
(setq aa9 (entnext aa9)
      aa11 (entget aa9))

(if (= (cdr (assoc 0 aa11)) "ATTDEF")(progn

(setq aa8 (ssadd aa9 aa8)
      aa14 (assoc 2 aa11)
      aa15 (cdr (assoc aa14 aa13)))

(if aa15 (if (/= (vl-string-trim " " (cdar aa15)) "")
(entmake (cons '(0 . "TEXT") aa15))
))

))
)
))

(setq aa3 nil)

(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa3 T)
)
)

(if (setq aa3 (ssget "_F" aa1 '((-4 . "<OR")
            (0 . "ACAD_TABLE")
;;;            (0 . "*DIMENSION")
;;;            (0 . "LEADER")
            (-4 . "OR>")
)))
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))

(if (setq aa3 (ssget "_CP" aa1 '((0 . "HATCH"))))(progn

(setq aa6 (entlast)
      aa7 (sslength aa3))

(repeat aa7

(setq aa10 (ssname aa3 (setq aa7 (1- aa7)))
      aa9 (assoc 450 (entget aa10)))

(if (= (cdr aa9) 1)
(entmod (subst (cons 450 0) aa9 (entget aa10))))

(command "_-hatchedit" aa10 "_b" "_r" "_n")

(if (null (entnext aa6))(progn
(command "_-hatchedit" aa10 "_b" "_p" "_n"
     "_-hatchedit" aa10 "_di"
     "_-hatchedit" aa10 "_as" "_s")

(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa8 (ssadd aa6 aa8))
(command aa6)
)

(command "" ""
     "_-hatchedit" aa10 "_b" "_r" "_n")
))

(if (entnext aa6)(progn
(setq aa6 (entnext aa6)
      aa8 (ssadd aa6 aa8))
(command "_-hatchedit" aa10 "_di"
     "_-hatchedit" aa10 "_as" "_s" aa6 "" "")
))

(if (= (cdr aa9) 1)(progn
(setq aa9 (entget aa10))
(entmod (subst (cons 450 1) (assoc 450 aa9) aa9))
))

)
))

(if (setq aa3 (ssget "_CP" aa1 '((0 . "REGION"))))(progn

(command "_.copy" aa4 "" '(0 0 0) '(0 0 0)
     "_.region" (entlast) "")

(setq aa7 (sslength aa3)
      aa6 (entlast)
      aa8 (ssadd aa6 aa8))

(repeat aa7
(command "_.copy" aa6 "" '(0 0 0) '(0 0 0))
(setq aa8 (ssadd (entlast) aa8))
(command "_.intersect" (ssname aa3 (setq aa7 (1- aa7))) (entlast) "")
)
))

;;;(if (setq aa3 (ssget "_F" aa1 '((0 . "IMAGE"))))
;;;(repeat (setq aa7 (sslength aa3))
;;;(command "_.imageclip" (ssname aa3 (setq aa7 (1- aa7))) "_n" "_p")
;;;(repeat (setq aa6 (length aa1))(command (nth (setq aa6 (1- aa6)) aa1)))
;;;(command "_c")
;;;))

(setq aa3 (ssget "_CP" aa1)
      aa6 '())

(mapcar '(lambda (q)

(if (= (car q) 10)
(setq aa6 (cons (trans (cdr q) 0 1) aa6)))

)(entget aa5))

(setq aa6 (cons (last aa6) aa6))

(if aa3 (command "_.move" aa3 "" '(0 0 0) '(0 0 0)))

(repeat 4
(command "_.trim" aa4 "" "_f")

(repeat (setq aa5 (length aa6))
(command (nth (setq aa5 (1- aa5)) aa6))
)

(while (= (getvar 'cmdactive) 1)(command ""))
)

(if (setq aa5 (ssget "_CP" aa6 '((0 . "*POLYLINE"))))(progn
(vl-cmdf "_.pedit" "_m" aa5 "" "_w" 0 "")
(setq aa5 (ssget "_F"  aa6 '((0 . "*POLYLINE"))))
(command "_.undo" 1)
))

(setq aa9 (ssget "_F" aa6 '((-4 . "<OR")(-4 . "<NOT")(-4 . "<OR")
             (0 . "HATCH")
             (0 . "*POLYLINE")
             (0 . "*TEXT")
             (0 . "REGION")
             (0 . "INSERT")
;;;             (0 . "IMAGE")
             (-4 . "OR>")(-4 . "NOT>")
             (0 . "*DIMENSION,LEADER");Без размеров
             (-4 . "OR>")
             )))

(command "_.erase" aa8)
(if aa9 (command aa9 ))
(if aa5 (command aa5 ))
(command "")

(setq aa3 (ssget "_CP" aa6)
      aa10 (getvar "FIELDEVAL")
      aa6 "den")

(while (or (tblsearch "block" aa6)
      (findfile (setq aa1 (strcat (getvar "tempprefix") aa6 ".dwg"))))
(setq aa6 (strcat aa6 "1")))

(if aa3 (progn

(command "_.wblock" aa1 "" (trans aa2 0 1) aa3 aa4 ""
     "_.undo" "_b"
;;;     "_fieldeval" 0
     "_.insert" aa1 "_none" (trans aa2 0 1))

(while (= (getvar 'cmdactive) 1)
(command ""))

(vl-file-delete aa1)

(setq aa2 (trans aa2 0 1)
      aa5 (entlast)
      aa3 1.0)

(while aa2

(vl-cmdf "_.move" aa5 "" "_none" aa2)

(princ (strcat "\nУкажите положение элемента или <Масштаб>:"))

(setq aa1 (vl-cmdf pause)
      aa8 (getvar 'lastprompt))

(if aa1
(if (equal aa2 (getvar "LASTPOINT") 1e-6)(progn

(if (setq aa1 (vl-string-search ">:" aa8))
(setq aa1 (substr aa8 (+ aa1 3))))

(if (= aa1 "0")
(setq aa2 nil)(progn
(command "_.erase" aa5 ""
     "_.insert" aa6 "_none" (setq aa2 (cadr (grread 1 1))) aa3)
(while (= (getvar 'cmdactive) 1)
(command ""))

(princ "\nМасштаб <")(princ aa3)(princ ">:")
(initget 128)
(if (vl-catch-all-error-p
(setq aa7 (vl-catch-all-apply 'getkword)))
(setq aa7 ""))

(if (null aa7)(setq aa7 ""))

(setq aa7 (vl-string-translate ",:" "./" aa7)
      aa4 (atof aa7))

(if (setq aa5 (vl-string-search "/" aa7))
(if (= (setq aa5 (atof (substr aa7 (+ aa5 2)))) 0)
(setq aa4 aa3)
(setq aa4 (/ aa4 aa5))
))

(if (= aa4 0)(setq aa4 aa3))

(setq aa7 (* (/ 1.0 aa3) aa4)
      aa3 aa4
      aa5 (entlast))

(vl-cmdf "_.scale" aa5 "" "_none" aa2 aa7)
)))
(setq aa2 nil)
)
(setq aa2 nil
      aa8 nil)
)
)

(setq aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
      aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(setvar "EXPLMODE" aa1)
(setvar "FIELDEVAL" aa10)

(if (eq (type (vl-catch-all-apply 'vla-Item (list aa4 aa6))) 'VLA-OBJECT)
(vl-catch-all-apply 'vla-Delete (list (vla-Item aa4 aa6))))

(while (entnext aa5)
(setq aa5 (entnext aa5)
      aa1 (entget aa5))

(if (/= aa3 1)             ;Если вместо "(/= aa3 1)" "nil", то
 ;  без сохранения масштаба штриховки и глоб.толщины полилиний
(if (= (cdr (assoc 0 aa1)) "HATCH")
(if (setq aa2 (assoc 41 aa1))(progn

(entmod (subst (cons 41 (/ (cdr aa2) aa3)) aa2 aa1))

(command "_-hatchedit" aa5 "_p")
(while (= (getvar 'cmdactive) 1)(command ""))

))(if (wcmatch (cdr (assoc 0 aa1)) "*POLYLINE")
(if (setq aa2 (assoc 43 aa1))
(vl-cmdf "_.pedit" "_m" aa5 "" "_w" (/ (cdr aa2) aa3) "")
))
))
)
)
(command "_.undo" "_b")
)
))

(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(if (null aa8)(command "_.undo" 1))

)
(princ "\nДля AutoCAD с 2006 версии")
)
(princ)
)

АлексЮстасу

АлексЮстасу
Участник

На форуме с 24 мая 2009г.
Сообщений: 94
Спасибо: 1

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Один из благодарных пользователей (skkkk) Ваших творений посоветовал обратиться. :) Тем более, что решаемая здесь задача родственна моим.
Я тут ношусь по инету аж с двумя связанными идеями:
1. создания замкнутых контуров фигур по их границам, образованным пересечениями полилиний или линий. Дело в том, что фирменная boundary непредсказуема, неточна и просто иногда вообще неправильна (см. http://forum.dwg.ru/showthread.php?t=34360, мои посты №7 и 11).
2. удаления из замкнутых контуров содержимого. Сразу из всех указанных (например, фигур из полилиний из указанного слоя или прямо выбранных) попавших туда фрагментов указанных элементов (тоже из указанных слоев или выборки). Тут проблема в том, чтобы удалить можно было сразу из множества контуров - из одного есть много способов.

Денис Флюстиков

Денис Флюстиков
Активный участник

На форуме с 12 октября 2005г.
Сообщений: 374
Спасибо: 10

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Вернулся. Отвечаю.
Александр, для решения данных задач требуются новые программы, на что сейчас совсем не готов. Если честно, не хочется тратить время на то, что не может пригодиться в моей работе. Так, что извини. А если есть замечания и предложения по моим кодам, пиши, буду искать время на правку, т.к. и сам заинтересован в лучшей работе тех программ, которыми пользуюсь, да и чувствую ответственность за те коды, которые здесь выложил.

А программа «Отрисовка внешнего контура выбранных объектов» не подходит по п.1?

skkkk

skkkk
Участник

На форуме с 22 апреля 2008г.
Сообщений: 31
Спасибо: 0

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Денис, всё также успешно и с превеликим удовольствием пользую Ваш лисп, за что огромное спасибо!
Вот возникла тут только у меня невозможность одна :)
Программка не строит фрагмент, если в контуре (из выбираемой ломанной полилинии ) имеются дуговые сегменты. Это поправимо?

Денис Флюстиков

Денис Флюстиков
Активный участник

На форуме с 12 октября 2005г.
Сообщений: 374
Спасибо: 10

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

skkkk,
Думаю, что это реально. Постараюсь в ближайшее время добавить в программу и эту возможность.

Денис Флюстиков

Денис Флюстиков
Активный участник

На форуме с 12 октября 2005г.
Сообщений: 374
Спасибо: 10

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

;|====================================================
Фрагмент чертежа по прямоуг.,кругл. или ломаной границе
(программа тестировалась на AutoCAD 2006, 2008, 2009)

Программа Дениса Флюстикова "Fragm_Den" от 03.09.09:
Возможность выбора полилинии с дуговыми сегментами в качестве границы

Макрос для кнопки:
^C^C^P(load "Fragm_Den");Fragm_Den

Замечания и предложения по адресу fd-@mail.ru
====================================================|; 

(defun c:Fragm_Den (/ *error* aa1 aa2 aa3 aa4 aa5 aa6 aa7 aa8 aa9
            aa10 aa11 aa12 aa13 aa14 aa15)

(if (>= (atof (getvar "ACADVER")) 16.2)(progn

(initget 128 "К Л")

(setq aa10 "Размер" ;Слой построения контура
      aa8 (ssadd)
      aa2 nil
      aa5 nil
      aa1 (getpoint "\nПервая точка прямоугольной области или [Круглая/Ломаная]:"))

(vl-load-com)

(cond
((= (type aa1) 'LIST)
   (if (setq aa2 (getcorner aa1 "\nВторая точка области:"))(progn
(setq aa1 (trans aa1 1 0)
      aa2 (trans aa2 1 0)
      aa7 (list (cons 10 aa1)
      (cons 10 (list (car aa1)(cadr aa2)))
      (cons 10 aa2)
      (cons 10 (list (car aa2)(cadr aa1))))
)
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")

)
))
((= aa1 "К")

(initget 1)
(setq aa1 (getpoint "\nЦентр круглой области:"))

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")
(if aa10 (if (tblsearch "Layer" aa10)(setvar "CLAYER" aa10)))

(princ "\nРадиус области:")

(vl-cmdf "_.circle" aa1)
(while (= (getvar 'cmdactive) 1)
(setq aa2 (vl-cmdf pause)))

(if aa2 (progn
(setq aa2 (cadr (grread 1 1))
      aa2 (trans aa2 1 0)
      aa4 (entlast)
      aa3 (vlax-ename->vla-object aa4)
      aa5 (vlax-curve-getEndParam aa3)
      aa5 (vlax-curve-getDistAtParam aa3 aa5)
      aa5 (/ aa5 256.0)
      aa1 0
      aa7 '())

(repeat 256
(setq aa7 (append aa7 (list (cons 10 (vlax-curve-getpointatdist aa3 aa1))))
      aa1 (+ aa1 aa5))
)

)))
(T

(setq aa1 (getpoint "\nПервая точка ломаной границы или <Выбрать>:"))

(if aa1 (progn

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")

(princ "\nСледующая точка границы:")

(if (vl-cmdf "_.line" aa1 pause)(progn

(setq aa1 (list aa1))
(princ "\nСледующая точка границы или <Прервать>:")

(while (= (getvar 'cmdactive) 1)
(setq aa3 (getvar "lastpoint")
      aa7 (car aa1)
      aa6 aa1
      aa1 (cons aa3 aa1)
      aa8 (ssadd (entlast) aa8))

(if (equal (last aa1) aa3 1e-6)
(vl-cmdf "")(progn

(while (> (length aa6) 2)
(setq aa6 (cdr aa6))
(if (or (inters aa3 aa7 (car aa6)(cadr aa6) t)
    (equal (angle aa3 aa7)(angle (caddr aa1) aa7) 1e-6)
    (equal aa3 aa7 1e-6))(progn
(vl-cmdf "_u")
(princ "\nСамопересечение границы\nСледующая точка границы или <Прервать>:")
(setq aa1 (cdr aa1)
      aa6 nil)))
)
(setq aa3 (vl-cmdf pause))
))
)
))

(if (and aa3 (> (length aa1) 2))
(setq aa2 (trans (getvar "lastpoint") 1 0)
      aa7 '())(progn
(setq aa2 nil)
(command "_.undo" "_b")
))

(mapcar '(lambda (q) (setq aa7 (append aa7 (list (cons 10 (trans q 1 0)))))) aa1)
)(progn

(setq aa1 (entsel "\nВыберите полилинию или <Выход>:"))

(if aa1 (progn

(setq aa2 (trans (cadr aa1) 1 0)
      aa4 (car aa1)
      aa5 (entget aa4)
      aa11 aa4
      aa7 '())

(if (wcmatch (cdr (assoc 0 aa5)) "*POLYLINE")(progn
(if (= (cdr (assoc 0 aa5)) "POLYLINE")(while aa11

(setq aa11 (entnext aa11)
      aa9 (entget aa11))

(if (= (cdr (assoc 0 aa9)) "VERTEX")
(setq aa7 (append aa7 (list (assoc 10 aa9)))
      aa7 (append aa7 (list (assoc 42 aa9))))
)
(if (= (cdr (assoc 0 aa9)) "SEQEND")
(setq aa11 nil
      aa5 aa7
      aa7 '())
)))

(setq aa5 (append aa5 (list '(10)))
      aa9 nil
      aa11 (vlax-ename->vla-object aa4))

(mapcar '(lambda (q)
(if (= (car q) 10)(if aa9 (progn

(if (cdr q)
(setq aa12 (vlax-curve-getDistAtPoint aa11 (cdr q)))
(setq aa12 (vlax-curve-getDistAtParam aa11 (vlax-curve-getEndParam aa11)))
)

(setq aa13 (vlax-curve-getDistAtPoint aa11 (cdr (last aa7)))
      aa9 (fix (abs (/ (atan aa9) pi 1e-3)))
      aa12 (/ (- aa12 aa13) aa9))

(repeat aa9
(setq aa13 (+ aa13 aa12)
      aa7 (append aa7 (list (cons 10 (vlax-curve-getPointAtDist aa11 aa13)))))
)
)(if (cdr q)(setq aa7 (append aa7 (list q)))))
(if (= (car q) 42)(if (= (setq aa9 (cdr q)) 0)(setq aa9 nil)
)))) aa5)

(if (< (length aa7) 3)(progn
(setq aa2 nil)
(princ "\nВыбранная полилиния имеет меньше трех вершин")
))
)(progn
(setq aa2 nil)
(princ "\nВыбранный объект не является полилинией")
))
))

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m") 

)
)
)
)

(if aa2 (progn

(defun *error* (msg)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(if (< (atof (getvar "ACADVER")) 17.1)
(vla-sendcommand (vla-get-activedocument
(vlax-get-acad-object)) "_.undo 1 ")
(command nil nil nil nil "_.undo" 1))
(princ "\nВыход во время обработки данных\n")
)

(if aa10 (if (tblsearch "Layer" aa10)(setvar "CLAYER" aa10)))

(setq aa3 (list (cons 0 "LWPOLYLINE")(cons 100 "AcDbEntity")(cons 100 "AcDbPolyline"))
      aa7 (append (list (cons 90 (length aa7))(cons 70 1)) aa7)
      aa1 '())

(entmake (append aa3 aa7))

(mapcar '(lambda (q)

(if (= (car q) 10)
(setq aa1 (cons (trans (cdr q) 0 1) aa1)))

) aa7)

(if aa5
(setq aa8 (ssadd (entlast) aa8))
(setq aa4 (entlast))
)

(setvar "OSMODE" 0)
(setvar "LTSCALE" 0.0001)

(command "_.shademode" 2
     "_.zoom" "_o" (entlast) ""
     "_.offset" (/ (getvar "VIEWSIZE") 2e4)(entlast)(getvar "VSMAX") ""
     "_.zoom" "_o" (setq aa5 (entlast) aa6 aa5) "")

(setvar "EXPLMODE" 1)

(while aa3
 ; Блоки расчленить: "_CP" - все в выбранной области, "_F" - на границе:
(setq aa3 (ssget "_F" aa1 '((0 . "INSERT")))
      aa9 aa6)

(if aa3
(repeat (setq aa7 (sslength aa3))

(setq aa10 (ssname aa3 (setq aa7 (1- aa7)))
      aa11 (entget aa10)
      aa12 aa10
      aa13 '())

(if (= (cdr (assoc 66 aa11)) 1)(progn

;;;(command "_.attsync" "_s" aa10 "_y")

(while (/= "SEQEND" (cdr (assoc 0 aa11)))

(if (= (cdr (assoc 0 aa11)) "ATTRIB")(progn

(setq aa14 '())

(foreach aa15 '(2 1 7 8 10 11 39 40 41 50 51 62 71 73)(progn
(if (/= (assoc aa15 aa11) nil)
(setq aa14 (append aa14 (list (assoc aa15 aa11)))))))

(setq aa13 (cons aa14 aa13))

))

(setq aa12 (entnext aa12)
      aa11 (entget aa12))

)
))

(command "_.explode" aa10)

(while (entnext aa9)
(setq aa9 (entnext aa9)
      aa11 (entget aa9))

(if (= (cdr (assoc 0 aa11)) "ATTDEF")(progn

(setq aa8 (ssadd aa9 aa8)
      aa14 (assoc 2 aa11)
      aa15 (cdr (assoc aa14 aa13)))

(if aa15 (if (/= (vl-string-trim " " (cdar aa15)) "")
(entmake (cons '(0 . "TEXT") aa15))
))

))
)
))

(setq aa3 nil)

(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa3 T)
)
)

(if (setq aa3 (ssget "_F" aa1 '((-4 . "<OR")
            (0 . "ACAD_TABLE")
;;;            (0 . "*DIMENSION")
;;;            (0 . "LEADER")
            (-4 . "OR>")
)))
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))

(if (setq aa12 (ssadd)
      aa3 (ssget "_CP" aa1 '((0 . "HATCH"))))(progn

(setq aa6 (entlast)
      aa7 (sslength aa3))

(repeat aa7

(setq aa10 (ssname aa3 (setq aa7 (1- aa7)))
      aa9 (assoc 450 (entget aa10)))

(if (= (cdr aa9) 1)
(entmod (subst (cons 450 0) aa9 (entget aa10))))

(command "_-hatchedit" aa10 "_b" "_r" "_n")

(if (null (entnext aa6))(progn
(command "_-hatchedit" aa10 "_b" "_p" "_n"
     "_-hatchedit" aa10 "_di"
     "_-hatchedit" aa10 "_as" "_s")

(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa8 (ssadd aa6 aa8)
      )
(command aa6)
)

(command "" ""
     "_-hatchedit" aa10 "_b" "_r" "_n")
))

(if (entnext aa6)(progn
(setq aa6 (entnext aa6)
      aa8 (ssadd aa6 aa8)
      aa12 (ssadd aa6 aa12)
      )
(command "_-hatchedit" aa10 "_di"
     "_-hatchedit" aa10 "_as" "_s" aa6 "" "")
))

(if (= (cdr aa9) 1)(progn
(setq aa9 (entget aa10))
(entmod (subst (cons 450 1) (assoc 450 aa9) aa9))
))
)
))

(if (setq aa3 (ssget "_CP" aa1 '((0 . "REGION"))))
(repeat (setq aa11 (sslength aa3))
(setq aa11 (1- aa11)
      aa12 (ssadd (ssname aa3 aa11) aa12))
))

(if (> (sslength aa12) 0)(progn
(command "_.copy" aa4 "" '(0 0 0) '(0 0 0)
     "_.region" (entlast) "")

(setq aa7 (sslength aa12)
      aa6 (entlast)
      aa8 (ssadd aa6 aa8))

(repeat aa7
(command "_.copy" aa6 "" '(0 0 0) '(0 0 0))
(setq aa8 (ssadd (entlast) aa8))
(command "_.intersect" (ssname aa12 (setq aa7 (1- aa7))) (entlast) "")
)
))

;;;(if (setq aa3 (ssget "_F" aa1 '((0 . "IMAGE"))))
;;;(repeat (setq aa7 (sslength aa3))
;;;(command "_.imageclip" (ssname aa3 (setq aa7 (1- aa7))) "_n" "_p")
;;;(repeat (setq aa6 (length aa1))(command (nth (setq aa6 (1- aa6)) aa1)))
;;;(command "_c")
;;;))

(setq aa3 (ssget "_CP" aa1)
      aa6 '())

(mapcar '(lambda (q)

(if (= (car q) 10)
(setq aa6 (cons (trans (cdr q) 0 1) aa6)))

)(entget aa5))

(setq aa6 (cons (last aa6) aa6))

(if aa3 (command "_.move" aa3 "" '(0 0 0) '(0 0 0)))

(repeat 4
(command "_.trim" aa4 "" "_f")

(repeat (setq aa5 (length aa6))
(command (nth (setq aa5 (1- aa5)) aa6))
)

(while (= (getvar 'cmdactive) 1)(command ""))
)

(setq aa10 (entdel aa4))

(if (setq aa5 (ssget "_CP" aa6 '((0 . "*POLYLINE"))))(progn
(vl-cmdf "_.pedit" "_m" aa5 "" "_w" 0 "")
(setq aa5 (ssget "_F"  aa6 '((0 . "*POLYLINE"))))
(command "_.undo" 1)
))

(setq aa9 (ssget "_F" aa6 '((-4 . "<OR")(-4 . "<NOT")(-4 . "<OR")
             (0 . "HATCH")
             (0 . "*POLYLINE")
             (0 . "*TEXT")
             (0 . "REGION")
             (0 . "INSERT")
;;;             (0 . "IMAGE")
             (-4 . "OR>")(-4 . "NOT>")
             (0 . "*DIMENSION,LEADER");Без размеров
             (-4 . "OR>")
             )))

(entdel aa10)
(command "_.erase" aa8)
(if aa9 (command aa9 ))
(if aa5 (command aa5 ))
(command "")

(setq aa3 (ssget "_CP" aa6)
      aa10 (getvar "FIELDEVAL")
      aa6 "den")

(while (or (tblsearch "block" aa6)
      (findfile (setq aa1 (strcat (getvar "tempprefix") aa6 ".dwg"))))
(setq aa6 (strcat aa6 "1")))

(if aa3 (progn

(command "_.wblock" aa1 "" (trans aa2 0 1) aa3 aa4 ""
     "_.undo" "_b"
;;;     "_fieldeval" 0
     "_.insert" aa1 "_none" (trans aa2 0 1))

(while (= (getvar 'cmdactive) 1)
(command ""))

(vl-file-delete aa1)

(setq aa2 (trans aa2 0 1)
      aa5 (entlast)
      aa3 1.0)

(while aa2

(vl-cmdf "_.move" aa5 "" "_none" aa2)

(princ (strcat "\nУкажите положение элемента или <Масштаб>:"))

(setq aa1 (vl-cmdf pause)
      aa8 (getvar 'lastprompt))

(if aa1
(if (equal aa2 (getvar "LASTPOINT") 1e-6)(progn

(if (setq aa1 (vl-string-search ">:" aa8))
(setq aa1 (substr aa8 (+ aa1 3))))

(if (= aa1 "0")
(setq aa2 nil)(progn
(command "_.erase" aa5 ""
     "_.insert" aa6 "_none" (setq aa2 (cadr (grread 1 1))) aa3)
(while (= (getvar 'cmdactive) 1)
(command ""))

(princ "\nМасштаб <")(princ aa3)(princ ">:")
(initget 128)
(if (vl-catch-all-error-p
(setq aa7 (vl-catch-all-apply 'getkword)))
(setq aa7 ""))

(if (null aa7)(setq aa7 ""))

(setq aa7 (vl-string-translate ",:" "./" aa7)
      aa4 (atof aa7))

(if (setq aa5 (vl-string-search "/" aa7))
(if (= (setq aa5 (atof (substr aa7 (+ aa5 2)))) 0)
(setq aa4 aa3)
(setq aa4 (/ aa4 aa5))
))

(if (= aa4 0)(setq aa4 aa3))

(setq aa7 (* (/ 1.0 aa3) aa4)
      aa3 aa4
      aa5 (entlast))

(vl-cmdf "_.scale" aa5 "" "_none" aa2 aa7)
)))
(setq aa2 nil)
)
(setq aa2 nil
      aa8 nil)
)
)

(setq aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
      aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(setvar "EXPLMODE" aa1)
(setvar "FIELDEVAL" aa10)

(if (eq (type (vl-catch-all-apply 'vla-Item (list aa4 aa6))) 'VLA-OBJECT)
(vl-catch-all-apply 'vla-Delete (list (vla-Item aa4 aa6))))

(while (entnext aa5)
(setq aa5 (entnext aa5)
      aa1 (entget aa5))

(if (/= aa3 1)             ;Если вместо "(/= aa3 1)" "nil", то
 ;  без сохранения масштаба штриховки и глоб.толщины полилиний
(if (= (cdr (assoc 0 aa1)) "HATCH")
(if (setq aa2 (assoc 41 aa1))(progn

(entmod (subst (cons 41 (/ (cdr aa2) aa3)) aa2 aa1))

(command "_-hatchedit" aa5 "_p")
(while (= (getvar 'cmdactive) 1)(command ""))

))(if (wcmatch (cdr (assoc 0 aa1)) "*POLYLINE")
(if (setq aa2 (assoc 43 aa1))
(vl-cmdf "_.pedit" "_m" aa5 "" "_w" (/ (cdr aa2) aa3) "")
))
))
)
)
(command "_.undo" "_b")
)
))

(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(if (null aa8)(command "_.undo" 1))

)
(princ "\nДля AutoCAD с 2006 версии")
)
(princ)
)

skkkk

skkkk
Участник

На форуме с 22 апреля 2008г.
Сообщений: 31
Спасибо: 0

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Проверил. Все отлично! Больше у меня не осталось ни одной мысли, что можно еще добавить в этот шедевр! Очередная огромная благодарность Денису!!!!

kheylan

kheylan
Участник

Откуда: Свердловская / Екатеринбург
На форуме с 1 апреля 2008г.
Сообщений: 18
Спасибо: 0

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Денис спасибо за программу!
Рад что она совершенствуется! Предложение - добавить команду Clipit из Express или что то, чтобы делало подобное, чтобы можно было обрезать маскировку (Wipeout), растры (Image), ссылки (Xref) и блоки, не разбивая их.
Очень бы помогло!

Денис Флюстиков

Денис Флюстиков
Активный участник

На форуме с 12 октября 2005г.
Сообщений: 374
Спасибо: 10

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

;|====================================================
Фрагмент чертежа по прямоуг.,кругл. или ломаной границе
(программа тестировалась на AutoCAD 2006, 2008, 2009)

Программа Дениса Флюстикова "Fragm_Den" от 14.09.09:
Возможность обработки блоков через "_.xclip"

Макрос для кнопки:
^C^C^P(load "Fragm_Den");Fragm_Den

Замечания и предложения по адресу fd-@mail.ru
====================================================|; 

(defun c:Fragm_Den (/ *error* aa1 aa2 aa3 aa4 aa5 aa6 aa7 aa8 aa9
            aa10 aa11 aa12 aa13 aa14 aa15)

(if (>= (atof (getvar "ACADVER")) 16.2)(progn

(initget 128 "К Л")

(setq aa10 "Размер" ; Слой построения контура
      aa15 0        ; 1- Расчленение блоков, 0- через "_.xclip"
      aa8 (ssadd)
      aa2 nil
      aa5 nil
      aa1 (getpoint "\nПервая точка прямоугольной области или [Круглая/Ломаная]:"))

(vl-load-com)

(cond
((= (type aa1) 'LIST)
   (if (setq aa2 (getcorner aa1 "\nВторая точка области:"))(progn
(setq aa1 (trans aa1 1 0)
      aa2 (trans aa2 1 0)
      aa7 (list (cons 10 aa1)
      (cons 10 (list (car aa1)(cadr aa2)))
      (cons 10 aa2)
      (cons 10 (list (car aa2)(cadr aa1))))
)
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")

)
))
((= aa1 "К")

(initget 1)
(setq aa1 (getpoint "\nЦентр круглой области:"))

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")
(if aa10 (if (tblsearch "Layer" aa10)(setvar "CLAYER" aa10)))

(princ "\nРадиус области:")

(vl-cmdf "_.circle" aa1)
(while (= (getvar 'cmdactive) 1)
(setq aa2 (vl-cmdf pause)))

(if aa2 (progn
(setq aa2 (cadr (grread 1 1))
      aa2 (trans aa2 1 0)
      aa4 (entlast)
      aa3 (vlax-ename->vla-object aa4)
      aa5 (vlax-curve-getEndParam aa3)
      aa5 (vlax-curve-getDistAtParam aa3 aa5)
      aa5 (/ aa5 256.0)
      aa1 0
      aa7 '())

(repeat 256
(setq aa7 (append aa7 (list (cons 10 (vlax-curve-getpointatdist aa3 aa1))))
      aa1 (+ aa1 aa5))
)

)))
(T

(setq aa1 (getpoint "\nПервая точка ломаной границы или <Выбрать>:"))

(if aa1 (progn

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")

(princ "\nСледующая точка границы:")

(if (vl-cmdf "_.line" aa1 pause)(progn

(setq aa1 (list aa1))
(princ "\nСледующая точка границы или <Прервать>:")

(while (= (getvar 'cmdactive) 1)
(setq aa3 (getvar "lastpoint")
      aa7 (car aa1)
      aa6 aa1
      aa1 (cons aa3 aa1)
      aa8 (ssadd (entlast) aa8))

(if (equal (last aa1) aa3 1e-6)
(vl-cmdf "")(progn

(while (> (length aa6) 2)
(setq aa6 (cdr aa6))
(if (or (inters aa3 aa7 (car aa6)(cadr aa6) t)
    (equal (angle aa3 aa7)(angle (caddr aa1) aa7) 1e-6)
    (equal aa3 aa7 1e-6))(progn
(vl-cmdf "_u")
(princ "\nСамопересечение границы\nСледующая точка границы или <Прервать>:")
(setq aa1 (cdr aa1)
      aa6 nil)))
)
(setq aa3 (vl-cmdf pause))
))
)
))

(if (and aa3 (> (length aa1) 2))
(setq aa2 (trans (getvar "lastpoint") 1 0)
      aa7 '())(progn
(setq aa2 nil)
(command "_.undo" "_b")
))

(mapcar '(lambda (q) (setq aa7 (append aa7 (list (cons 10 (trans q 1 0)))))) aa1)
)(progn

(setq aa1 (entsel "\nВыберите полилинию или <Выход>:"))

(if aa1 (progn

(setq aa2 (trans (cadr aa1) 1 0)
      aa4 (car aa1)
      aa5 (entget aa4)
      aa11 aa4
      aa7 '())

(if (wcmatch (cdr (assoc 0 aa5)) "*POLYLINE")(progn
(if (= (cdr (assoc 0 aa5)) "POLYLINE")(while aa11

(setq aa11 (entnext aa11)
      aa9 (entget aa11))

(if (= (cdr (assoc 0 aa9)) "VERTEX")
(setq aa7 (append aa7 (list (assoc 10 aa9)))
      aa7 (append aa7 (list (assoc 42 aa9))))
)
(if (= (cdr (assoc 0 aa9)) "SEQEND")
(setq aa11 nil
      aa5 aa7
      aa7 '())
)))

(setq aa5 (append aa5 (list '(10)))
      aa9 nil
      aa11 (vlax-ename->vla-object aa4))

(mapcar '(lambda (q)
(if (= (car q) 10)(if aa9 (progn

(if (cdr q)
(setq aa12 (vlax-curve-getDistAtPoint aa11 (cdr q)))
(setq aa12 (vlax-curve-getDistAtParam aa11 (vlax-curve-getEndParam aa11)))
)

(if (null (setq aa13 (vlax-curve-getDistAtPoint aa11 (cdr (last aa7)))))
(setq aa13 0))
(setq aa9 (fix (abs (/ (atan aa9) pi 1e-3)))
      aa12 (/ (- aa12 aa13) aa9))

(repeat aa9
(setq aa13 (+ aa13 aa12)
      aa7 (append aa7 (list (cons 10 (vlax-curve-getPointAtDist aa11 aa13)))))
)
)(if (cdr q)(setq aa7 (append aa7 (list q)))))
(if (= (car q) 42)(if (= (setq aa9 (cdr q)) 0)(setq aa9 nil)
)))) aa5)

(if (< (length aa7) 3)(progn
(setq aa2 nil)
(princ "\nВыбранная полилиния имеет меньше трех вершин")
))
)(progn
(setq aa2 nil)
(princ "\nВыбранный объект не является полилинией")
))
))

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")

)
)
)
)

(if aa2 (progn

(defun *error* (msg)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(if (< (atof (getvar "ACADVER")) 17.1)
(vla-sendcommand (vla-get-activedocument
(vlax-get-acad-object)) "_.undo 1 ")
(command nil nil nil nil "_.undo" 1))
(princ "\nВыход во время обработки данных\n")
)

(if aa10 (if (tblsearch "Layer" aa10)(setvar "CLAYER" aa10)))

(setq aa3 (list (cons 0 "LWPOLYLINE")(cons 100 "AcDbEntity")(cons 100 "AcDbPolyline"))
      aa7 (append (list (cons 90 (length aa7))(cons 70 1)) aa7)
      aa1 '())

(entmake (append aa3 aa7))

(mapcar '(lambda (q)

(if (= (car q) 10)
(setq aa1 (cons (trans (cdr q) 0 1) aa1)))

) aa7)

(if aa5
(setq aa8 (ssadd (entlast) aa8))
(setq aa4 (entlast))
)

(setvar "OSMODE" 0)
(setvar "LTSCALE" 0.0001)

(command "_.shademode" 2
     "_.zoom" "_o" (entlast) ""
     "_.offset" (/ (getvar "VIEWSIZE") 2e4)(entlast)(getvar "VSMAX") ""
     "_.zoom" "_o" (setq aa5 (entlast) aa6 aa5) "")

(setvar "EXPLMODE" 1)

(if (= aa15 0)(progn

(setq aa3 (ssget "_F" aa1 '((0 . "INS ERT")))
      aa9 aa6)

(if aa3
(repeat (setq aa7 (sslength aa3))

(setq aa10 (ssname aa3 (setq aa7 (1- aa7)))
      aa11 (entget aa10))

(command "_.xclip" aa10 "" "_n")

(if (and (setq aa11 (member '(102 . "{ACAD_XDICTIONARY") aa11))
     (setq aa11 (cdr aa11))
     (setq aa10 (cdr (assoc 360 aa11)))
     (setq aa11 (entget aa10))
     (assoc 360 (member '(3 . "ACAD_FILTER") aa11))
     )
(command "_y")
)
(command "_p")
(repeat (setq aa10 (length aa1))
(command (nth (setq aa10 (1- aa10)) aa1))
)
(command "")
))

)
(while aa3
 ; Блоки расчленить: "_CP" - все в выбранной области, "_F" - на границе:
(setq aa3 (ssget "_F" aa1 '((0 . "INS ERT")))
      aa9 aa6)

(if aa3
(repeat (setq aa7 (sslength aa3))

(setq aa10 (ssname aa3 (setq aa7 (1- aa7)))
      aa11 (entget aa10)
      aa12 aa10
      aa13 '())

(if (= (cdr (assoc 66 aa11)) 1)(progn

 ;(command "_.attsync" "_s" aa10 "_y")

(while (/= "SEQEND" (cdr (assoc 0 aa11)))

(if (= (cdr (assoc 0 aa11)) "ATTRIB")(progn

(setq aa14 '())

(foreach aa15 '(2 1 7 8 10 11 39 40 41 50 51 62 71 73)(progn
(if (/= (assoc aa15 aa11) nil)
(setq aa14 (append aa14 (list (assoc aa15 aa11)))))))

(setq aa13 (cons aa14 aa13))

))

(setq aa12 (entnext aa12)
      aa11 (entget aa12))

)
))

(command "_.explode" aa10)

(while (entnext aa9)
(setq aa9 (entnext aa9)
      aa11 (entget aa9))

(if (= (cdr (assoc 0 aa11)) "ATTDEF")(progn

(setq aa8 (ssadd aa9 aa8)
      aa14 (assoc 2 aa11)
      aa15 (cdr (assoc aa14 aa13)))

(if aa15 (if (/= (vl-string-trim " " (cdar aa15)) "")
(entmake (cons '(0 . "TEXT") aa15))
))

))
)
))

(setq aa3 nil)

(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa3 T)
)
)
)

(if (setq aa3 (ssget "_F" aa1 '((-4 . "<OR")
            (0 . "ACAD_TABLE")
;;;            (0 . "*DIMENSION")
;;;            (0 . "LEADER")
            (-4 . "OR>")
)))
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))

(if (setq aa12 (ssadd)
      aa3 (ssget "_CP" aa1 '((0 . "HATCH"))))(progn

(setq aa6 (entlast)
      aa7 (sslength aa3))

(repeat aa7

(setq aa10 (ssname aa3 (setq aa7 (1- aa7)))
      aa9 (assoc 450 (entget aa10)))

(if (= (cdr aa9) 1)
(entmod (subst (cons 450 0) aa9 (entget aa10))))

(command "_-hatchedit" aa10 "_b" "_r" "_n")

(if (null (entnext aa6))(progn
(command "_-hatchedit" aa10 "_b" "_p" "_n"
     "_-hatchedit" aa10 "_di"
     "_-hatchedit" aa10 "_as" "_s")

(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa8 (ssadd aa6 aa8)
      )
(command aa6)
)

(command "" ""
     "_-hatchedit" aa10 "_b" "_r" "_n")
))

(if (entnext aa6)(progn
(setq aa6 (entnext aa6)
      aa8 (ssadd aa6 aa8)
      aa12 (ssadd aa6 aa12)
      )
(command "_-hatchedit" aa10 "_di"
     "_-hatchedit" aa10 "_as" "_s" aa6 "" "")
))

(if (= (cdr aa9) 1)(progn
(setq aa9 (entget aa10))
(entmod (subst (cons 450 1) (assoc 450 aa9) aa9))
))
)
))

(if (setq aa3 (ssget "_CP" aa1 '((0 . "REGION"))))
(repeat (setq aa11 (sslength aa3))
(setq aa11 (1- aa11)
      aa12 (ssadd (ssname aa3 aa11) aa12))
))

(if (> (sslength aa12) 0)(progn
(command "_.copy" aa4 "" '(0 0 0) '(0 0 0)
     "_.region" (entlast) "")

(setq aa7 (sslength aa12)
      aa6 (entlast)
      aa8 (ssadd aa6 aa8))

(repeat aa7
(command "_.copy" aa6 "" '(0 0 0) '(0 0 0))
(setq aa8 (ssadd (entlast) aa8))
(command "_.intersect" (ssname aa12 (setq aa7 (1- aa7))) (entlast) "")
)
))

;;;(if (setq aa3 (ssget "_F" aa1 '((0 . "IMAGE"))))
;;;(repeat (setq aa7 (sslength aa3))
;;;(command "_.imageclip" (ssname aa3 (setq aa7 (1- aa7))) "_n" "_p")
;;;(repeat (setq aa6 (length aa1))(command (nth (setq aa6 (1- aa6)) aa1)))
;;;(command "_c")
;;;))

(setq aa3 (ssget "_CP" aa1)
      aa6 '())

(mapcar '(lambda (q)

(if (= (car q) 10)
(setq aa6 (cons (trans (cdr q) 0 1) aa6)))

)(entget aa5))

(setq aa6 (cons (last aa6) aa6))

(if aa3 (command "_.move" aa3 "" '(0 0 0) '(0 0 0)))

(repeat 4
(command "_.trim" aa4 "" "_f")

(repeat (setq aa5 (length aa6))
(command (nth (setq aa5 (1- aa5)) aa6))
)

(while (= (getvar 'cmdactive) 1)(command ""))
)

(setq aa10 (entdel aa4))

(if (setq aa5 (ssget "_CP" aa6 '((0 . "*POLYLINE"))))(progn
(vl-cmdf "_.pedit" "_m" aa5 "" "_w" 0 "")
(setq aa5 (ssget "_F"  aa6 '((0 . "*POLYLINE"))))
(command "_.undo" 1)
))

(setq aa9 (ssget "_F" aa6 '((-4 . "<OR")(-4 . "<NOT")(-4 . "<OR")
             (0 . "HATCH")
             (0 . "*POLYLINE")
             (0 . "*TEXT")
             (0 . "REGION")
             (0 . "INS ERT")
;;;             (0 . "IMAGE")
             (-4 . "OR>")(-4 . "NOT>")
             (0 . "*DIMENSION,LEADER");Без размеров
             (-4 . "OR>")
             )))

(entdel aa10)
(command "_.erase" aa8)
(if aa9 (command aa9 ))
(if aa5 (command aa5 ))
(command "")

(setq aa3 (ssget "_CP" aa6)
      aa10 (getvar "FIELDEVAL")
      aa6 "den")

(while (or (tblsearch "block" aa6)
      (findfile (setq aa1 (strcat (getvar "tempprefix") aa6 ".dwg"))))
(setq aa6 (strcat aa6 "1")))

(if aa3 (progn

(command "_.wblock" aa1 "" (trans aa2 0 1) aa3 aa4 ""
     "_.undo" "_b"
;;;     "_fieldeval" 0
     "_.ins ert" aa1 "_none" (trans aa2 0 1))

(while (= (getvar 'cmdactive) 1)
(command ""))

(vl-file-delete aa1)

(setq aa2 (trans aa2 0 1)
      aa5 (entlast)
      aa3 1.0)

(while aa2

(vl-cmdf "_.move" aa5 "" "_none" aa2)

(princ (strcat "\nУкажите положение элемента или <Масштаб>:"))

(setq aa1 (vl-cmdf pause)
      aa8 (getvar 'lastprompt))

(if aa1
(if (equal aa2 (getvar "LASTPOINT") 1e-6)(progn

(if (setq aa1 (vl-string-search ">:" aa8))
(setq aa1 (substr aa8 (+ aa1 3))))

(if (= aa1 "0")
(setq aa2 nil)(progn
(command "_.erase" aa5 ""
     "_.ins ert" aa6 "_none" (setq aa2 (cadr (grread 1 1))) aa3)
(while (= (getvar 'cmdactive) 1)
(command ""))

(princ "\nМасштаб <")(princ aa3)(princ ">:")
(initget 128)
(if (vl-catch-all-error-p
(setq aa7 (vl-catch-all-apply 'getkword)))
(setq aa7 ""))

(if (null aa7)(setq aa7 ""))

(setq aa7 (vl-string-translate ",:" "./" aa7)
      aa4 (atof aa7))

(if (setq aa5 (vl-string-search "/" aa7))
(if (= (setq aa5 (atof (substr aa7 (+ aa5 2)))) 0)
(setq aa4 aa3)
(setq aa4 (/ aa4 aa5))
))

(if (= aa4 0)(setq aa4 aa3))

(setq aa7 (* (/ 1.0 aa3) aa4)
      aa3 aa4
      aa5 (entlast))

(vl-cmdf "_.scale" aa5 "" "_none" aa2 aa7)
)))
(setq aa2 nil)
)
(setq aa2 nil
      aa8 nil)
)
)

(setq aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
      aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(setvar "EXPLMODE" aa1)
(se tvar "FIELDEVAL" aa10)

(if (eq (type (vl-catch-all-apply 'vla-Item (list aa4 aa6))) 'VLA-OBJECT)
(vl-catch-all-apply 'vla-Delete (list (vla-Item aa4 aa6))))

(while (entnext aa5)
(se tq aa5 (entnext aa5)
      aa1 (entget aa5))

(if (/= aa3 1)             ;Если вместо "(/= aa3 1)" "nil", то
 ;  без сохранения масштаба штриховки и глоб.толщины полилиний
(if (= (cdr (assoc 0 aa1)) "HATCH")
(if (se tq aa2 (assoc 41 aa1))(progn

(entmod (subst (cons 41 (/ (cdr aa2) aa3)) aa2 aa1))

(command "_-hatchedit" aa5 "_p")
(while (= (getvar 'cmdactive) 1)(command ""))

))(if (wcmatch (cdr (assoc 0 aa1)) "*POLYLINE")
(if (se tq aa2 (assoc 43 aa1))
(vl-cmdf "_.pedit" "_m" aa5 "" "_w" (/ (cdr aa2) aa3) "")
))
))
)
)
(command "_.undo" "_b")
)
))

(se tvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(if (null aa8)(command "_.undo" 1))

)
(princ "\nДля AutoCAD с 2006 версии")
)
(princ)
)

kheylan

kheylan
Участник

Откуда: Свердловская / Екатеринбург
На форуме с 1 апреля 2008г.
Сообщений: 18
Спасибо: 0

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Денис закралась ошибка
"_.ins ert" aa1 " и так по всей программе
и после слияния, еще что-то мешает

VVA

VVA
Активный участник

Откуда: Беларусь / Минск
На форуме с 29 марта 2006г.
Сообщений: 1,859
Спасибо: 25

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Александр, Думаю Денис копировал все правильно. Вот цитата отсюда

Здесь что-то с движком форума. Он упорно разрывает имя функции.
Нужно найти строчку Код
(defun XINS ERT
и заменить на Код
(defun XINSERT

XINSERT - слитно, без пробела
Написал об этом администратору. Надеюсь, исправят.

Как видно, мое письмо проигнорировали :evil:

nonez

nonez
Участник

На форуме с 15 сентября 2009г.
Сообщений: 17
Спасибо: 0

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Command:
Command: Fragm_Den

Первая точка прямоугольной области или [Круглая/Ломаная]:
Вторая точка области:Outside mode - Objects outside boundary will be hidden.
Cannot TRIM this object.
Cannot TRIM this object.
Cannot TRIM this object.
Cannot TRIM this object.
Укажите положение элемента или <Масштаб>:
Выход во время обработки данных

Command: *Cancel*

вот что вываливается

Денис Флюстиков

Денис Флюстиков
Активный участник

На форуме с 12 октября 2005г.
Сообщений: 374
Спасибо: 10

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Код перекопировал, ошибка осталась, поэтому программу выложил архивом (+ иконка) на http://dwg.ru/dnl/6731 . Если есть замечания и предложения, то лучше на этой ветке, здесь мне легче отслеживать.

nonez, если данное сообщение идет не только в последней версии программы, прошу выслать DWG-файлик мне на fd-@mail.ru буду разбираться.

nonez

nonez
Участник

На форуме с 15 сентября 2009г.
Сообщений: 17
Спасибо: 0

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Денис Флюстиков,
с dwg.ru все нормальна работает, походу глюк на этом форуме

kheylan

kheylan
Участник

Откуда: Свердловская / Екатеринбург
На форуме с 1 апреля 2008г.
Сообщений: 18
Спасибо: 0

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Денис, все работает замечательно!
А зачем это скрывать?!
;;;(if (setq aa3 (ssget "_F" aa1 '((0 . "IMAGE"))))
;;;(repeat (setq aa7 (sslength aa3))
;;;(command "_.imageclip" (ssname aa3 (setq aa7 (1- aa7))) "_n" "_p")
;;;(repeat (setq aa6 (length aa1))(command (nth (setq aa6 (1- aa6)) aa1)))
;;;(command "_c")
;;;))

;;; (0 . "IMAGE")
С этим работает еще лучше, режет и растры (IMAGE) и ссылки (XREF)
Вот бы еще маскировку (WIPEOUT) - цены бы не было!
А так, просто круто!

Денис Флюстиков

Денис Флюстиков
Активный участник

На форуме с 12 октября 2005г.
Сообщений: 374
Спасибо: 10

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Александр пишет:

А зачем это скрывать?!

Александр,
Обработка растров отключена, т.к. работа программы при данном решении не всегда корректна, например, если есть предварительная обрезка, или контур имеет ломаную границу, или растр деформирован (например, LISP-ом с http://dwg.ru/dnl/538 ), или ...

Попробую это исправить, как и работу с маскировкой (WIPEOUT), может и получится программа, которой "цены бы не было" :)

Денис Флюстиков

Денис Флюстиков
Активный участник

На форуме с 12 октября 2005г.
Сообщений: 374
Спасибо: 10

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

"Fragm_Den" от 27.09.09, новое:
Обработка растров и маскировки

Денис Флюстиков

Денис Флюстиков
Активный участник

На форуме с 12 октября 2005г.
Сообщений: 374
Спасибо: 10

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

"Fragm_Den" от 28.09.09, новое:
Обработка маскировки и при выключенном контуре

kheylan

kheylan
Участник

Откуда: Свердловская / Екатеринбург
На форуме с 1 апреля 2008г.
Сообщений: 18
Спасибо: 0

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Спасибо, Денис за программу, все работает, работаешь с опережением пожеланий!
Но, аппетит приходит во время ..., хотелось бы опцию, выбора объектов для обрезки.
Еще забыты такие объекты для обрезки, как мультилиния (MLINE), поле (оно превращается в обычный текст),
группа (Group)- она разбивается.
Эта так для зарядки. А так все СУПЕРСКИ!

nonez

nonez
Участник

На форуме с 15 сентября 2009г.
Сообщений: 17
Спасибо: 0

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Тогда уж дополню, а также прокси объекты и объекты надстроек на AutoCAD типа объектов СПДС

VVA

VVA
Активный участник

Откуда: Беларусь / Минск
На форуме с 29 марта 2006г.
Сообщений: 1,859
Спасибо: 25

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

nonez пишет:

Тогда уж дополню, а также прокси объекты и объекты надстроек на AutoCAD типа объектов СПДС

Для них существует другая программа

Денис Флюстиков

Денис Флюстиков
Активный участник

На форуме с 12 октября 2005г.
Сообщений: 374
Спасибо: 10

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

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

LISP. Фрагмент чертежа по прямоуг. или кругл. границе (Страница 2 из 5)

Сообщения с 26 по 50 из 113

#26 Ответ от Денис Флюстиков 20 мая 2009г. 23:17:32

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#27 Ответ от kheylan 22 мая 2009г. 22:49:09

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#28 Ответ от Денис Флюстиков 23 мая 2009г. 13:17:40

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#29 Ответ от Денис Флюстиков 25 мая 2009г. 10:58:13

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#30 Ответ от АлексЮстасу 14 августа 2009г. 03:13:42

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#31 Ответ от Денис Флюстиков 25 августа 2009г. 10:14:37

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#32 Ответ от skkkk 30 августа 2009г. 23:52:16

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#33 Ответ от Денис Флюстиков 1 сентября 2009г. 07:12:44

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#34 Ответ от Денис Флюстиков 3 сентября 2009г. 15:14:18

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#35 Ответ от skkkk 4 сентября 2009г. 15:21:17

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#36 Ответ от kheylan 10 сентября 2009г. 13:12:51

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#37 Ответ от Денис Флюстиков 16 сентября 2009г. 16:41:49 (изменено: Денис Флюстиков, 21 сентября 2009г. 09:24:05)

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#38 Ответ от kheylan 18 сентября 2009г. 14:59:46

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#39 Ответ от VVA 18 сентября 2009г. 17:02:21 (изменено: Владимир Азарко, 18 сентября 2009г. 17:03:00)

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#40 Ответ от nonez 18 сентября 2009г. 17:35:52

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#41 Ответ от Денис Флюстиков 21 сентября 2009г. 09:29:15

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#42 Ответ от nonez 21 сентября 2009г. 11:52:02

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#43 Ответ от kheylan 21 сентября 2009г. 13:22:00

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#44 Ответ от Денис Флюстиков 22 сентября 2009г. 13:14:30

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#45 Ответ от Денис Флюстиков 27 сентября 2009г. 12:06:25

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#46 Ответ от Денис Флюстиков 28 сентября 2009г. 08:14:29

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#47 Ответ от kheylan 29 сентября 2009г. 21:26:44

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#48 Ответ от nonez 30 сентября 2009г. 09:13:16

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#49 Ответ от VVA 30 сентября 2009г. 13:17:55

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

#50 Ответ от Денис Флюстиков 30 сентября 2009г. 19:34:42

Re: LISP. Фрагмент чертежа по прямоуг. или кругл. границе

Сообщения с 26 по 50 из 113

Тему читают: 1 гость

Вход на форум «Форумы CADUser»x

Ссылки