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

;|====================================================
Получает фрагмент чертежа по прямоуг. или кругл. границе
Программа Дениса Флюстикова "Fragm_Den" от 17.11.08
(тестировалась только на AutoCAD 2008)
Макрос для кнопки:
^C^C^P(load "Fragm_Den");Fragm_Den
Замечания и предложения по адресу fd-@mail.ru
====================================================|;
(defun c:Fragm_Den (/ aa1 aa2 aa3 aa4 aa5 aa6 aa7 aa8)
(setq aa8 "Размер" ;Слой построения контура
      aa1 (getpoint "\nПервая точка прямоугольной области или <Круглая>:")
      aa2 nil
      aa6 nil)
(vl-load-com)
(if aa1
(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))))
)
(setvar "CMDECHO" 0)
(command "_.undo" "_g"
     "_.undo" "_m")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
)
)(progn
(setq aa1 (getpoint "\nЦентр круглой области:"))
(setvar "CMDECHO" 0)
(command "_.undo" "_g"
     "_.undo" "_m")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
(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)
      aa6 (* (cdr (assoc 40 (entget aa4))) 0.001)
      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)))))
(setq aa1 (+ aa1 aa5)))
))))
(if aa2 (progn
(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 aa6
(setq aa8 (entlast))
(setq aa6 0.01
      aa4 (entlast)
      aa8 (ssadd))
)
(setvar "OSMODE" 0)
(setvar "LTSCALE" 0.0001)
(command "_.offset" aa6 (entlast)(getvar "EXTMAX") ""
     "_.zoom" "_o" (setq aa5 (entlast) aa6 aa5) "")
(setvar "EXPLMODE" 1)
(while aa3
(setq aa3 (ssget "_F" aa1 '((-4 . "<OR")
                (0 . "INSERT")
                ;(0 . "DIMENSION")
                ;(0 . "LEADER")
                (-4 . "OR>"))))
(if aa3
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))
(setq aa3 nil)
(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa3 T)
)
)
;;;(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)
      aa5 (length aa6))
(command "_.move" aa3 "" '(0 0 0) '(0 0 0)
     "_.trim" aa4 "" "_f")
(repeat aa5
(command (nth (setq aa5 (1- aa5)) aa6))
)
(command "" ""
     "_.erase" (ssget "_F" aa6
              '((-4 . "<NOT")(0 . "HATCH")(-4 . "NOT>"))
;;;              '((-4 . "<NOT")(0 . "HATCH,IMAGE")(-4 . "NOT>"))
              )
     aa5 aa8 "")
(setq aa6 "den")
(while (or (tblsearch "block" aa6)
       (findfile (setq aa1 (strcat (getvar "tempprefix") aa6 ".dwg"))))
(setq aa6 (strcat aa6 "1")))
(command "_.wblock" aa1 "" (trans aa2 0 1) aa3 aa4 ""
     "_.undo" "_b"
     "_.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))
(if (and aa1 (equal aa2 (getvar "LASTPOINT") 1e-6))(progn
(setq aa1 (getvar 'lastprompt)
      aa1 (substr aa1 (+ (vl-string-search ">:" 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 aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
      aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(setvar "EXPLMODE" aa1)
(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))))
))
(command "_.undo" "_e")
(setvar "CMDECHO" 1)
(princ)
)

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

Вот если бы программка еще и не полностью попавшие в рамку объекты разделяла по границе рамки....

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

> DEN
Программа и должна обрезать объекты по заданной границе, но ПОКА это делает не всегда.
Подробнее:
1. С растровыми картинками эта функция заложена в коде, но отключена, т.к. ПОКА нет обработки уже подрезанного растра.
2. Если убрать ";" в строчках ";(0 . "DIMENSION")" и ";(0 . "LEADER")" , то размеры и выноски попадающие на границу предварительно будут взорваны, и далее полученные примитивы обрезаны.
3. Со штриховкой сложнее, буду думать.
4. Не всегда корректно обрабатываются полилинии, здесь ПОКА не знаю, что предпринять.
5. С остальными объектами (о тексте не говорю, зачем часть слова или букв) вроде все ОК.

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

Предложение по улучшению:неплохо было бы добавить запрос типа-"Вставить обозначение в чертеж?" и собственно вставку текста с обозначением фрагмента и рядом в скобках масштаб 1:Х,где Х берется из ранее заданного запроса на масштаб.Если масштаб не указывался(1:1)то его с обозначением не ставить.Надеюсь мысль выразил понятно.Да,для обрезки полилиний может быть подойдет что то из лиспа BreakObjects.lsp.

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

> getr
Спасибо за предложение.
Была идейка объединить эту с программой обозначения выносного элемента.
https://www.caduser.ru/forum/topic24200.html

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

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

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

Хорошая прожка, спасибо!

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

;|====================================================
Получает фрагмент чертежа по прямоуг. или кругл. границе
Программа Дениса Флюстикова "Fragm_Den" от 23.11.08
Новое:
- Работа с полилиниями и областями
Макрос для кнопки:
^C^C^P(load "Fragm_Den");Fragm_Den
Замечания и предложения по адресу fd-@mail.ru
(программа тестировалась только на AutoCAD 2008)
====================================================|;
(defun c:Fragm_Den (/ aa1 aa2 aa3 aa4 aa5 aa6 aa7 aa8 aa9)
(if (>= (atof (getvar "ACADVER")) 16.2)(progn
(setq aa8 "Размер" ;Слой построения контура
      aa1 (getpoint "\nПервая точка прямоугольной области или <Круглая>:")
      aa2 nil
      aa6 nil)
(vl-load-com)
(if aa1
(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))))
)
(setvar "CMDECHO" 0)
(command "_.undo" "_g"
     "_.undo" "_m")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
)
)(progn
(setq aa1 (getpoint "\nЦентр круглой области:"))
(setvar "CMDECHO" 0)
(command "_.undo" "_g"
     "_.undo" "_m")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
(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)
      aa6 (* (cdr (assoc 40 (entget aa4))) 0.001)
      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)))))
(setq aa1 (+ aa1 aa5)))
))))
(if aa2 (progn
(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 aa6
(setq aa8 (ssadd (entlast)(ssadd)))
(setq aa6 0.01
      aa4 (entlast)
      aa8 (ssadd))
)
(setvar "OSMODE" 0)
(setvar "LTSCALE" 0.0001)
(command "_.shademode" 2
     "_.offset" aa6 (entlast)(getvar "EXTMAX") ""
     "_.zoom" "_o" (setq aa5 (entlast) aa6 aa5) "")
(setvar "EXPLMODE" 1)
(while aa3
(setq aa3 (ssget "_CP" aa1 '((-4 . "<OR")
                (0 . "INSERT")
                (0 . "DIMENSION")
                (0 . "LEADER")
                (-4 . "OR>"))))
(if aa3
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))
(setq aa3 nil)
(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa3 T)
)
)
(if (setq aa3 (ssget "_F" aa1 '((0 . "REGION"))))(progn
(command "_.copy" aa4 "" '(0 0 0) '(0 0 0)
     "_.region" (entlast) "")
(setq aa7 (sslength aa3)
      aa6 (entlast)
      aa9 (1+ aa7))
(repeat aa7
(command "_.copy" aa6 "" '(0 0 0) '(0 0 0)
     "_.intersect" (ssname aa3 (setq aa7 (1- aa7))) (entlast) "")
(if (/= (- aa9 (setq aa9 (sslength (ssget "_F" aa1 '((0 . "REGION")))))) 0)
(setq aa8 (ssadd (entlast) aa8))
)
)
(setq aa8 (ssadd aa6 aa8))
))
;;;(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)
      aa5 (length aa6))
(command "_.move" aa3 "" '(0 0 0) '(0 0 0)
     "_.trim" aa4 "" "_f")
(repeat aa5
(command (nth (setq aa5 (1- aa5)) aa6))
)
(command "" "")
(if (setq aa5 (ssget "_CP" aa6 '((0 . "*POLYLINE"))))(progn
(command "_.pedit" "_m" aa5 "" "_w" 0 "")
(setq aa5 (ssget "_F"  aa6 '((0 . "*POLYLINE"))))
(command "_.undo" 1)
))
(setq aa6 (ssget "_F" aa6 '((-4 . "<NOT")(-4 . "<OR")
                (0 . "HATCH")
                (0 . "*POLYLINE")
                (0 . "*TEXT")
                (0 . "REGION")
;;;                (0 . "IMAGE")
                (-4 . "OR>")(-4 . "NOT>"))))
(command "_.erase" aa8)
(if aa6 (command aa6 ))
(if aa5 (command aa5 ))
(command "")
(setq aa3 (ssget "_CP" aa1)
      aa6 "den")
(while (or (tblsearch "block" aa6)
       (findfile (setq aa1 (strcat (getvar "tempprefix") aa6 ".dwg"))))
(setq aa6 (strcat aa6 "1")))
(command "_.wblock" aa1 "" (trans aa2 0 1) aa3 aa4 ""
     "_.undo" "_b"
     "_.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))
(if (and aa1 (equal aa2 (getvar "LASTPOINT") 1e-6))(progn
(setq aa1 (getvar 'lastprompt)
      aa1 (substr aa1 (+ (vl-string-search ">:" 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 aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
      aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(setvar "EXPLMODE" aa1)
(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))))
))
(command "_.undo" "_e")
(setvar "CMDECHO" 1)
)
(princ "\nДля AutoCAD с 2006 версии")
)
(princ)
)

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

;|====================================================
Получает фрагмент чертежа по прямоуг. или кругл. границе
Программа Дениса Флюстикова "Fragm_Den" от 25.11.08
Новое:
- Работа со штриховками
Макрос для кнопки:
^C^C^P(load "Fragm_Den");Fragm_Den
Замечания и предложения по адресу fd-@mail.ru
(программа тестировалась только на AutoCAD 2008)
====================================================|;
(defun c:Fragm_Den (/ *error* aa1 aa2 aa3 aa4 aa5 aa6 aa7 aa8)
(if (>= (atof (getvar "ACADVER")) 16.2)(progn
(setq aa8 "Размер" ;Слой построения контура
      aa1 (getpoint "\nПервая точка прямоугольной области или <Круглая>:")
      aa2 nil
      aa6 nil)
(vl-load-com)
(if aa1
(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")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
)
)(progn
(setq aa1 (getpoint "\nЦентр круглой области:"))
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
(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)
      aa6 (* (cdr (assoc 40 (entget aa4))) 0.001)
      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)))))
(setq aa1 (+ aa1 aa5)))
))))
(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")
)    
(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 aa6
(setq aa8 (ssadd (entlast)(ssadd)))
(setq aa6 0.01
      aa4 (entlast)
      aa8 (ssadd))
)
(setvar "OSMODE" 0)
(setvar "LTSCALE" 0.0001)
(command "_.shademode" 2
     "_.offset" aa6 (entlast)(getvar "EXTMAX") ""
     "_.zoom" "_o" (setq aa5 (entlast) aa6 aa5) "")
(setvar "EXPLMODE" 1)
(while aa3
(setq aa3 (ssget "_CP" aa1 '((0 . "INSERT"))))
(if aa3
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))
(setq aa3 nil)
(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa3 T)
)
)
(if (setq aa3 (ssget "_F" aa1 '((0 . "*DIMENSION,LEADER"))))
(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
(command "_-hatchedit" (ssname aa3 (setq aa7 (1- aa7))) "_b" "_r" "_n")
(if (null (entnext aa6))(progn
(command "_-hatchedit" (ssname aa3 aa7) "_b" "_p" "_n"
     "_-hatchedit" (ssname aa3 aa7) "_di"
     "_-hatchedit" (ssname aa3 aa7) "_as" "_s")
(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa8 (ssadd aa6 aa8))
(command aa6)
)
(command "" ""
     "_-hatchedit" (ssname aa3 aa7) "_b" "_r" "_n")
))
(if (entnext aa6)(progn
(setq aa6 (entnext aa6)
      aa8 (ssadd aa6 aa8))
(command "_-hatchedit" (ssname aa3 aa7) "_di"
     "_-hatchedit" (ssname aa3 aa7) "_as" "_s" aa6 "" "")
))
)
))
(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)
      aa5 (length aa6))
(command "_.move" aa3 "" '(0 0 0) '(0 0 0)
     "_.trim" aa4 "" "_f")
(repeat aa5
(command (nth (setq aa5 (1- aa5)) aa6))
)
(command "" "")
(if (setq aa5 (ssget "_CP" aa6 '((0 . "*POLYLINE"))))(progn
(command "_.pedit" "_m" aa5 "" "_w" 0 "")
(setq aa5 (ssget "_F"  aa6 '((0 . "*POLYLINE"))))
(command "_.undo" 1)
))
(setq aa6 (ssget "_F" aa6 '((-4 . "<NOT")(-4 . "<OR")
                (0 . "HATCH")
                (0 . "*POLYLINE")
                (0 . "*TEXT")
                (0 . "REGION")
;;;                (0 . "IMAGE")
                (-4 . "OR>")(-4 . "NOT>"))))
(command "_.erase" aa8)
(if aa6 (command aa6 ))
(if aa5 (command aa5 ))
(command "")
(setq aa3 (ssget "_CP" aa1)
      aa6 "den")
(while (or (tblsearch "block" aa6)
       (findfile (setq aa1 (strcat (getvar "tempprefix") aa6 ".dwg"))))
(setq aa6 (strcat aa6 "1")))
(command "_.wblock" aa1 "" (trans aa2 0 1) aa3 aa4 ""
     "_.undo" "_b"
     "_.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))
(if (and aa1 (equal aa2 (getvar "LASTPOINT") 1e-6))(progn
(setq aa1 (getvar 'lastprompt)
      aa1 (substr aa1 (+ (vl-string-search ">:" 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 aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
      aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(setvar "EXPLMODE" aa1)
(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")(progn
(setq aa2 (assoc 41 aa1)
      aa2 (subst (cons 41 (/ (cdr aa2) aa3)) aa2 aa1))
(entmod aa2)
(command "_-hatchedit" aa5 "_p")
(while (= (getvar 'cmdactive) 1)(command ""))
)))
)
))
(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
)
(princ "\nДля AutoCAD с 2006 версии")
)
(princ)
)

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

Мне очень помогла прога при составлении исполнительных съемок. Часто приходиться вырезать кусок проекта и на нем выставлять фактические отклонения. Жаль что не всегда (50% примерно) срабатывает...
Command: Fragm_Den
Первая точка прямоугольной области или <Круглая>:
Вторая точка области:
Use the Hatch Edit dialog box to modify gradients.
Invalid window specification.
Command:
Выход во время обработки данных
Причем в одном и том же чертеже.. Половину нормально обрабатывает, а вторую половину не хочет...

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

> Андрей
Пока сложно сказать из-за чего это происходит и даже не представляю какие примитивы используются в исполнительных съемках. Вышли пожалуйста файлик мне на fd-@mail.ru и желательно показать указываемые точки области и версию ACAD'а. А пока попробуй новый вариант из следующего сообщения, там подправлены некоторые мелочи.

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

;|====================================================
Получает фрагмент чертежа по прямоуг. или кругл. границе
(программа тестировалась на AutoCAD 2006, 2008)
Программа Дениса Флюстикова "Fragm_Den" от 28.11.08
Новое:
- Сохранение глобальной толщины полилиний при масштабировании
- подправлена работа на AutoCAD 2006
- и мелочи
Макрос для кнопки:
^C^C^P(load "Fragm_Den");Fragm_Den
Замечания и предложения по адресу fd-@mail.ru
====================================================|;
(defun c:Fragm_Den (/ *error* aa1 aa2 aa3 aa4 aa5 aa6 aa7 aa8)
(if (>= (atof (getvar "ACADVER")) 16.2)(progn
(setq aa8 "Размер" ;Слой построения контура
      aa1 (getpoint "\nПервая точка прямоугольной области или <Круглая>:")
      aa2 nil
      aa6 nil)
(vl-load-com)
(if aa1
(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")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
)
)(progn
(setq aa1 (getpoint "\nЦентр круглой области:"))
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
(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)
      aa6 (* (cdr (assoc 40 (entget aa4))) 0.001)
      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)))))
(setq aa1 (+ aa1 aa5)))
))))
(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")
)    
(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 aa6
(setq aa8 (ssadd (entlast)(ssadd)))
(setq aa6 0.01
      aa4 (entlast)
      aa8 (ssadd))
)
(setvar "OSMODE" 0)
(setvar "LTSCALE" 0.0001)
(command "_.shademode" 2
     "_.offset" aa6 (entlast)(getvar "VSMAX") ""
     "_.zoom" "_o" (setq aa5 (entlast) aa6 aa5) "")
(setvar "EXPLMODE" 1)
(while aa3
(setq aa3 (ssget "_CP" aa1 '((0 . "INSERT"))))
(if aa3
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))
(setq aa3 nil)
(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa3 T)
)
)
;;;(if (setq aa3 (ssget "_F" aa1 '((0 . "*DIMENSION,LEADER"))))
;;;(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
(command "_-hatchedit" (ssname aa3 (setq aa7 (1- aa7))) "_b" "_r" "_n")
(if (null (entnext aa6))(progn
(command "_-hatchedit" (ssname aa3 aa7) "_b" "_p" "_n"
     "_-hatchedit" (ssname aa3 aa7) "_di"
     "_-hatchedit" (ssname aa3 aa7) "_as" "_s")
(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa8 (ssadd aa6 aa8))
(command aa6)
)
(command "" ""
     "_-hatchedit" (ssname aa3 aa7) "_b" "_r" "_n"
     )
))
(if (entnext aa6)(progn
(setq aa6 (entnext aa6)
      aa8 (ssadd aa6 aa8))
(command "_-hatchedit" (ssname aa3 aa7) "_di"
     "_-hatchedit" (ssname aa3 aa7) "_as" "_s" aa6 "" "")
))
)
))
(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))
(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 aa6 (ssget "_F" aa6 '((-4 . "<OR")(-4 . "<NOT")(-4 . "<OR")
                (0 . "HATCH")
                (0 . "*POLYLINE")
                (0 . "*TEXT")
                (0 . "REGION")
;;;                (0 . "IMAGE")
                (-4 . "OR>")(-4 . "NOT>")
                (0 . "*DIMENSION,LEADER");Без размеров
                (-4 . "OR>")
                )))
(command "_.erase" aa8)
(if aa6 (command aa6 ))
(if aa5 (command aa5 ))
(command "")
(setq aa3 (ssget "_CP" aa1)
      aa6 "den")
(while (or (tblsearch "block" aa6)
       (findfile (setq aa1 (strcat (getvar "tempprefix") aa6 ".dwg"))))
(setq aa6 (strcat aa6 "1")))
(command "_.wblock" aa1 "" (trans aa2 0 1) aa3 aa4 ""
     "_.undo" "_b"
     "_.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))
(if (and aa1 (equal aa2 (getvar "LASTPOINT") 1e-6))(progn
(setq aa1 (getvar 'lastprompt)
      aa1 (substr aa1 (+ (vl-string-search ">:" 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 aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
      aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(setvar "EXPLMODE" aa1)
(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) "")
))
))
)
))
(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
)
(princ "\nДля AutoCAD с 2006 версии")
)
(princ)
)

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

;|====================================================
Фрагмент чертежа по прямоуг. или кругл. границе
(программа тестировалась на AutoCAD 2006, 2008)
Программа Дениса Флюстикова "Fragm_Den" от 10.12.08
Новое:
Отработано замечание > [url=https://www.caduser.ru/forum/topic44865.html]Андрей (2008-12-08 16:58:58)[/url]
https://www.caduser.ru/forum/topic44865.html
(Исправлена ошибка при работе с градиентной заливкой)
Макрос для кнопки:
^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)
(if (>= (atof (getvar "ACADVER")) 16.2)(progn
(setq aa8 "Размер" ;Слой построения контура
      aa1 (getpoint "\nПервая точка прямоугольной области или <Круглая>:")
      aa2 nil
      aa6 nil)
(vl-load-com)
(if aa1
(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")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
)
)(progn
(setq aa1 (getpoint "\nЦентр круглой области:"))
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(command "_.undo" "_m")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
(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)
      aa6 (* (cdr (assoc 40 (entget aa4))) 0.001)
      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)))))
(setq aa1 (+ aa1 aa5)))
))))
(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")
)    
(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 aa6
(setq aa8 (ssadd (entlast)(ssadd)))
(setq aa6 0.01
      aa4 (entlast)
      aa8 (ssadd))
)
(setvar "OSMODE" 0)
(setvar "LTSCALE" 0.0001)
(command "_.shademode" 2
     "_.offset" aa6 (entlast)(getvar "VSMAX") ""
     "_.zoom" "_o" (setq aa5 (entlast) aa6 aa5) "")
(setvar "EXPLMODE" 1)
(while aa3
(setq aa3 (ssget "_CP" aa1 '((0 . "INSERT"))))
(if aa3
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))
(setq aa3 nil)
(while (entnext aa6)
(setq aa6 (entnext aa6)
      aa3 T)
)
)
;;;(if (setq aa3 (ssget "_F" aa1 '((0 . "*DIMENSION,LEADER"))))
;;;(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))
(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 aa6 (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 aa6 (command aa6 ))
(if aa5 (command aa5 ))
(command "")
(setq aa3 (ssget "_CP" aa1)
      aa6 "den")
(while (or (tblsearch "block" aa6)
       (findfile (setq aa1 (strcat (getvar "tempprefix") aa6 ".dwg"))))
(setq aa6 (strcat aa6 "1")))
(command "_.wblock" aa1 "" (trans aa2 0 1) aa3 aa4 ""
     "_.undo" "_b"
     "_.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))
(if (and aa1 (equal aa2 (getvar "LASTPOINT") 1e-6))(progn
(setq aa1 (getvar 'lastprompt)
      aa1 (substr aa1 (+ (vl-string-search ">:" 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 aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
      aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(setvar "EXPLMODE" aa1)
(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) "")
))
))
)
))
(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
)
(princ "\nДля AutoCAD с 2006 версии")
)
(princ)
)

(изменено: skkkk, 8 мая 2009г. 03:17:42)

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

Почему-то не выходит никак круглую рамку включить.
Добавлено пятью минутами позднее:
Понял, просто надо на первый запрос команды ввести "К" и enter 2 раза нажать. Маленькая недоработочка, кажется. Но программка просто замечательная. Раньше я делал то же, разрывая объекты по рамке лиспом, и выделяя их внутри контура другим лиспом - во многотраз дольше выходило, а тут - просто красота. Спасибо автору!!!

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

Получение фрагмента чертежа по круглой границе должно происходить, если при вызове программы (в строке "Первая точка прямоугольной области или <Круглая>:") правый клик или «ENTER» или пробел. Далее версия, которая тоже уже написана давно, но т.к. пока нового в коде не чего не предвидится, то выкладываю ее.
А за благодарность спасибо, думаю, без отзывов многие программы остались бы без развития.

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

Программа Дениса Флюстикова "Fragm_Den" от 16.12.08
Новое:
- работа с таблицами

Макрос для кнопки:
^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)

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

(setq aa8 "Размер" ;Слой построения контура
      aa1 (getpoint "\nПервая точка прямоугольной области или <Круглая>:")
      aa2 nil
      aa6 nil)

(vl-load-com)
(if aa1
(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")
(if aa8 (if (tblsearch "Layer" aa8)(setvar "CLAYER" aa8)))
)
)(progn

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

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

(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)))))
(setq aa1 (+ aa1 aa5)))

))))

(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")
)     

(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)(ssadd)))
(setq aa4 (entlast)
      aa8 (ssadd))
)

(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
(setq aa3 (ssget "_CP" aa1 '((0 . "INSERT"))))

(if aa3
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))

(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))

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

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

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

(command "_.wblock" aa1 "" (trans aa2 0 1) aa3 aa4 ""
     "_.undo" "_b"
     "_.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))

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

(setq aa1 (getvar 'lastprompt)
      aa1 (substr aa1 (+ (vl-string-search ">:" 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 aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
      aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(setvar "EXPLMODE" aa1)

(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) "")
))
))
)
))

(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))

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

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

Отличная программа... к сожалению не помню из кого сообщения брал текст... но это к делу не относиться...

Разумное развитие программы дальше: вырезание части чертежа по неправильной произвольной замкнутой полилинии.

На сколько это возможно???

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

Выделение объктов в области контура
В посте #8 описан подобный процесс с произвольной замкнутой полилинией, правда требующий несколько большего количества манипуляций

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

Андрей Ice пишет:

................

Разумное развитие программы дальше: вырезание части чертежа по неправильной произвольной замкнутой полилинии.

На сколько это возможно???

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

Программа Дениса Флюстикова "Fragm_Den" от 16.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)

(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 "К")

(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Первая точка области:"))

(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))
))
)
))

(setq aa2 (trans (getvar "lastpoint") 1 0)
      aa7 '())

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

)
)

(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
(setq aa3 (ssget "_CP" aa1 '((0 . "INSERT"))))

(if aa3
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))

(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))

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

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

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

(command "_.wblock" aa1 "" (trans aa2 0 1) aa3 aa4 ""
    "_.undo" "_b"
    "_.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))

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

(setq aa1 (getvar 'lastprompt)
      aa1 (substr aa1 (+ (vl-string-search ">:" 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 aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
      aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(setvar "EXPLMODE" aa1)

(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) "")
))
))
)
))

(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))

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

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

Высший класс! Спасибо, Денис :)

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

Спасибо!!! Теперь можно забыть про СПДС

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

Решила опробовать в 2009 на самом сложном участке карты со множеством элементов и разнообразной штриховкой.....
Мяукнуть :o не успела....,всё было вынесено и очищено по высшему классу...
спасибо и дерзайте дальше,Денис :!:

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

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

Программа Дениса Флюстикова "Fragm_Den" от 17.05.09
Подправлена работа программы в случаях:
1. В режиме "ломаная граница" указаны только две точки.
2. При замыкании контура происходит самопересечение границы.
3. ESC-выход при указании ломаной границы.

Макрос для кнопки:
^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)

(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

(initget 1)
(setq aa1 (list (getpoint "\nПервая точка ломаной границы")))

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

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

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

(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)

)
)

(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
(setq aa3 (ssget "_CP" aa1 '((0 . "INSERT"))))

(if aa3
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))

(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))

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

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

(setq aa3 (ssget "_CP" aa1)
      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"
     "_.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))

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

(setq aa1 (getvar 'lastprompt)
      aa1 (substr aa1 (+ (vl-string-search ">:" 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 aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
      aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(setvar "EXPLMODE" aa1)

(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)))

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

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

Я не успеваю обновляться! :)  На мой взгляд, последнее, чего не хватает этой программе до ПОЛНОГО совершенства, так это опции "Выбрать имеющийся контур" наряду с "Круглая" и "Ломанная"

(изменено: Денис Флюстиков, 20 мая 2009г. 22:46:33)

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

Андрей Ice пишет:

...........

Разумное развитие программы дальше: вырезание части чертежа по неправильной произвольной замкнутой полилинии.

На сколько это возможно???

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

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

Макрос для кнопки:
^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)

(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
(setq aa3 (ssget "_CP" aa1 '((0 . "INSERT"))))

(if aa3
(repeat (setq aa7 (sslength aa3))
(command "_.explode" (ssname aa3 (setq aa7 (1- aa7))))
))

(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 . "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)
      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"
     "_.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))

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

(setq aa1 (getvar 'lastprompt)
      aa1 (substr aa1 (+ (vl-string-search ">:" 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 aa4 (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)))
      aa1 (getvar "EXPLMODE"))
(setvar "EXPLMODE" 1)
(command "_.explode" aa5)
(setvar "EXPLMODE" aa1)

(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)))

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

(изменено: skkkk, 20 мая 2009г. 23:10:21)

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

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

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