[Pain]

Народ мне нужна очень "ерьезная вещ"в автокаде))),а именно.....С помощью замкнутой полилинии я должен обвести облясть с энным каличеством ибьектов и при выделении этой полилинии должны выдилится все обьекты попавшие в контуры полилинии.Заранее говорю блок з0десь неподойдет потомучто эта полилиния должна легко изменять свою форму и соответственнол изменяется количество попавших обьектов в нуть этой самой линии и распределение обьектов по слоям тоже неподходит ибо это небыстрее чем расчет вручную :cry: .Может быть необходимо написать специалный скрипт для решения этой задачи.....может кто подскажет ...или это проще зделать в какой либо другой программе.Да и чтобы избавить вас от лышних вопросов сразу говорю все это нужно в области Градостроительства для быстрого подщета планогаммы расселения городов

[Dym]

tak na eto estj specialjno obuchennij vibor po konturu

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

А если попробовать группы?

[VVA]

>PAIN Пробуй

Код:

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

;| ! *******************************************************************
;; !                  lib:IsPtInView
;; ! *******************************************************************
;; ! Проверяет находится ли точка в видовом экране
;; ! Auguments: 'pt'  - Точка для анализа в МСК!!!
;; ! Return   : T или nil если 'pt' в видовом экране или нет
;; ! *******************************************************************|;
(defun lib:IsPtInView (pt / VCTR Y_Len SSZ X_Pix Y_Pix X_Len Lc Uc)
(setq pt (trans pt 0 1))  
(setq VCTR (getvar "VIEWCTR") Y_Len (getvar "VIEWSIZE")
   SSZ (getvar "SCREENSIZE")
   X_Pix (car SSZ) Y_Pix (cadr SSZ)
   X_Len (* (/ X_Pix Y_Pix) Y_Len)
   Lc (polar VCTR (dtr 180.0) (* 0.5 X_Len))
   Uc (polar Lc 0.0 X_Len)
   Lc (polar Lc (dtr 270.0) (* 0.5 Y_Len))
   Uc (polar Uc (dtr 90.0) (* 0.5 Y_Len)))
(if (and (> (car pt) (car Lc))(< (car pt) (car Uc))
	 (> (cadr pt) (cadr Lc))(< (cadr pt) (cadr Uc)))
	T nil))
(defun DTR (a)(* pi (/ a 180.0)))
;| ! ***************************************************************************
;; !           lib:pt_extents
;; ! ***************************************************************************
;; ! Function : Возвращает границы MIN, MAX X,Y,Z списка точек
;; ! Argument : 'vlist' - Список точек
;; ! Returns  : Список точек (ЛевНижн ПравВерхн)
;; ! ***************************************************************************|;
(defun  lib:pt_extents (vlist / tmp)
(setq tmp (mapcar '(lambda (x) (vl-remove-if 'null x))
 (mapcar '(lambda (what) (mapcar '(lambda (x) (nth what x)) vlist))
 '(0 1 2))));_setq
  (list (mapcar '(lambda(x)(apply 'min x)) tmp)(mapcar '(lambda(x)(apply 'max x)) tmp)));_defun

; ! ***********************************************************
;; !                             lib:Zoom2Lst
;; ! **********************************************************
;; ! Function : Zoom границ списка точек
;; ! Arguments: 'vlist' - Список точек в МСК!!!!
;; ! Зуммирует экран, чтобы все точки были видны
;; ! Returns  : t - было зуммирование nil - нет
;; ! **********************************************************
(defun lib:Zoom2Lst( vlist / bl tr Lst OS)
(setq	Lst (lib:pt_extents vlist) bl (car Lst) tr (cadr Lst))
(if (not (and (lib:IsPtInView bl) (lib:IsPtInView tr)))
(progn  (setq OS (getvar "OSMODE"))(setvar "OSMODE" 0)
(command "_.Zoom" "_Window" (trans bl 0 1)(trans tr 0 1)
	"_.Zoom" "0.95x")
(setvar "OSMODE" OS) T) NIL))

;****** Команда *******

(defun C:SPL ( / en pl n ss lst)
  (setq en (car(entsel "\nУкажите полилинию: ")))
  (if (and en (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE"))
    (progn (setq pl (vlax-ename->vla-object en) n 0)
      (while (<= n (vlax-curve-getEndParam pl))
	(setq lst (append lst (list (vlax-curve-getPointAtParam pl n)))
	      n   (1+ n)))
      (lib:Zoom2Lst lst);_Гарантированно полилиния на экране
      (setq lst (mapcar '(lambda(x)(trans x 0 1)) lst))
      (if (setq ss (ssget "_WP" lst))(SSSETFIRST ss ss))
      (setq ss nil)))(princ))
(princ "\nНаберите в командной строке SPL")

1. Выбор производится Рамкой многоугольника (_WP). Т.е. попадают объекты, которые полностью лежат внутри многоугольной области. Если нужно секущим многоугольником, замени текст

Код:

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

(ssget "_WP" lst)

на

Код:

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

(ssget "_CP" lst)

2. Полилиния контура должна быть выпуклой

***Добавлено*** 2011-03-14
Фрагмент чертежа по прямоугольной, круглой или ломаной границе
Команды: SCWP; SCCP
Выделение объектов путем указания существующего контура.
В качестве контура могут выступать сплайны, полилинии, дуги, круги, элипсы.
Контур должен быть выпуклым.

Код:

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

;;;Команды: SCWP; SCCP
;;;Выделение объектов путем указания существующего контура.
;;;В качестве контура могут выступать сплайны, полилинии, дуги, круги, элипсы.
;;;Контур должен быть выпуклым.
(defun SelectContour ( opt / en ss lst) 
(defun DTR (a)(* pi (/ a 180.0))) 
(defun  lib:pt_extents (vlist / tmp) 
(setq tmp (mapcar '(lambda (x) (vl-remove-if 'null x)) 
(mapcar '(lambda (what) (mapcar '(lambda (x) (nth what x)) vlist)) 
'(0 1 2))));_setq 
  (list (mapcar '(lambda(x)(apply 'min x)) tmp)(mapcar '(lambda(x)(apply 'max x)) tmp))) 
(defun lib:IsPtInView (pt / VCTR Y_Len SSZ X_Pix Y_Pix X_Len Lc Uc) 
(setq pt (trans pt 0 1)) 
(setq VCTR (getvar "VIEWCTR") Y_Len (getvar "VIEWSIZE") 
   SSZ (getvar "SCREENSIZE") 
   X_Pix (car SSZ) Y_Pix (cadr SSZ) 
   X_Len (* (/ X_Pix Y_Pix) Y_Len) 
   Lc (polar VCTR (dtr 180.0) (* 0.5 X_Len)) 
   Uc (polar Lc 0.0 X_Len) 
   Lc (polar Lc (dtr 270.0) (* 0.5 Y_Len)) 
   Uc (polar Uc (dtr 90.0) (* 0.5 Y_Len))) 
(if (and (> (car pt) (car Lc))(< (car pt) (car Uc)) 
    (> (cadr pt) (cadr Lc))(< (cadr pt) (cadr Uc))) 
   T nil)) 
(defun lib:Zoom2Lst( vlist / bl tr Lst OS) 
(setq   Lst (lib:pt_extents vlist) bl (car Lst) tr (cadr Lst)) 
(if (not (and (lib:IsPtInView bl) (lib:IsPtInView tr))) 
(progn  (setq OS (getvar "OSMODE"))(setvar "OSMODE" 0) 
(command "_.Zoom" "_Window" (trans bl 0 1)(trans tr 0 1) 
   "_.Zoom" "0.95x") 
(setvar "OSMODE" OS) T) NIL)) 
(defun TraceObject (obj / typlst typ TracePline TraceACE TraceLine 
                         TraceSpline TraceType1Pline 
                          TraceType23Pline) 
    (defun ZClosed (lst) 
    (if (and (vlax-curve-isClosed obj) 
       (not(equal (car lst)(last lst) 1e-6))) 
      (append lst (list (car lst))) 
      lst)) 
  (defun TracePline (obj / param endparam anginc tparam pt blg 
                           ptlst delta inc arcparam flag) 
    (setq param (vlax-curve-getStartParam obj) 
          endparam (vlax-curve-getEndParam obj) 
          anginc (* pi (/ 7.5 180.0))) 
    (setq tparam param) 
      (while (<= param endparam) 
        (setq pt (vlax-curve-getPointAtParam obj param)) 
        (if (not (equal pt (car ptlst) 1e-12)) 
          (setq ptlst (cons pt ptlst))) 
        (if  (and (/= param endparam) 
            (setq blg (abs (vlax-invoke obj 'GetBulge param))) 
            (/= 0 blg)) 
          (progn 
            (setq delta (* 4 (atan blg)) ;included angle 
                  inc (/ 1.0 (1+ (fix (/ delta anginc)))) 
                  arcparam (+ param inc)) 
            (while (< arcparam (1+ param)) 
              (setq pt (vlax-curve-getPointAtParam obj arcparam) 
                    ptlst (cons pt ptlst) 
                    arcparam (+ inc arcparam)))) 
        ) 
        (setq param (1+ param))) 
    (if (and (apply 'and ptlst) 
        (> (length ptlst) 1)) 
     (ZClosed (reverse ptlst)))) ;end 
  (defun TraceACE (obj / startparam endparam anginc 
                         delta div inc pt ptlst) 
    (setq startparam (vlax-curve-getStartParam obj) 
          endparam (vlax-curve-getEndParam obj) 
          anginc (* pi (/ 5.0 180.0))) 
    (if (equal endparam (* pi 2) 1e-12) 
      (setq delta endparam) 
      (setq delta (NormalAngle (- endparam startparam)))) 
    (setq div (1+ (fix (/ delta anginc))) 
          inc (/ delta div)) 
    (while (or 
        (< startparam endparam) 
        (equal startparam endparam 1e-12)) 
      (setq pt (vlax-curve-getPointAtParam obj startparam) 
            ptlst (cons pt ptlst) 
            startparam (+ inc startparam))) 
    (reverse ptlst)) ;end 
  (defun TraceLine (obj)(list (vlax-get obj 'StartPoint) 
        (vlax-get obj 'EndPoint))) 
  (defun TraceSpline (obj / startparam endparam ncpts inc param 
                            fd ptlst pt1 pt2 ang1 ang2 a) 
    (setq startparam (vlax-curve-getStartParam obj) 
          endparam (vlax-curve-getEndParam obj) 
          ncpts (vlax-get obj 'NumberOfControlPoints) 
          inc (/ (- endparam startparam) (* ncpts 7)) 
          param (+ inc startparam) 
          fd (vlax-curve-getfirstderiv obj param) 
          ptlst (cons (vlax-curve-getStartPoint obj) ptlst)) 
    (while (< param endparam) 
      (setq pt1 (vlax-curve-getPointAtParam obj param) 
            ang1 fd 
            param (+ param inc) 
            pt2 (vlax-curve-getPointAtParam obj param) 
            fd (vlax-curve-getfirstderiv obj param) 
            ang2 fd 
            a (abs (3d_angw1w2 ang1 ang2))) 
      (if (> a 0.00218166)(setq ptlst (cons pt1 ptlst)))) 
    (if (not (equal 
          (setq pt1 (vlax-curve-getEndPoint obj)) (car ptlst) 1e-8)) 
      (setq ptlst (cons pt1 ptlst))) 
    (reverse ptlst)) ;end 
  (defun TraceType1Pline (obj / ptlst objlst lst) 
    (setq ptlst (list (vlax-curve-getStartPoint obj)) 
          objlst (vlax-invoke obj 'Explode)) 
    (foreach x objlst 
      (setq lst (TraceACE x)) 
      (if (not (equal (car lst) (last ptlst) 1e-8)) 
        (setq lst (reverse lst))) 
      (setq ptlst (append ptlst (cdr lst))) 
      (vla-delete x))(ZClosed  ptlst)) ;end 
  (defun TraceType23Pline (obj / objlst ptlst lastpt) 
    (setq objlst (vlax-invoke obj 'Explode) 
          lastpt (vlax-get (last objlst) 'EndPoint)) 
    (foreach x objlst 
      (setq ptlst (cons (vlax-get x 'StartPoint) ptlst)) 
      (vla-delete x))(ZClosed (reverse (cons lastpt ptlst)))) ;end 
  (defun Trace3DPline (obj / coord ptlst) 
    (setq coord (vlax-get obj 'Coordinates)) 
    (repeat (/ (length coord) 3) 
      (setq ptlst (cons (list (car coord) (cadr coord)(caddr coord)) ptlst)) 
      (setq coord (cdddr coord)))(ZClosed (reverse ptlst))) ;end 
(defun NormalAngle (a)(if (numberp a)(angtof (angtos a 0 14) 0))) 
(defun 3d_angw1w2 (Wekt1 Wekt2 / CosA) 
(if (equal (setq CosA (/ (apply '+ (mapcar '* Wekt1 Wekt2)) 
        (distance '(0 0 0) Wekt1) (distance '(0 0 0) Wekt2))) -1.0 1e-6) 
  Pi 
  (if (equal CosA 0.0 1e-6) (* 0.5 PI)(atan (sqrt (- 1 (* CosA CosA))) CosA)))) 
  (setq typlst '("AcDb2dPolyline" "AcDbPolyline" "AcDb3dPolyline" "AcDbCircle" 
     "AcDbArc" "AcDbEllipse" "AcDbSpline" "AcDbLine")) 
  (or (eq (type obj) 'VLA-OBJECT) 
    (setq obj (vlax-ename->vla-object obj))) 
  (setq typ (vlax-get obj 'ObjectName)) 
  (if (vl-position typ typlst) 
    (cond ((or (eq typ "AcDb2dPolyline") (eq typ "AcDbPolyline")) 
      (cond ((or 
               (not (vlax-property-available-p obj 'Type)) 
               (= 0 (vlax-get obj 'Type))) 
              (TracePline obj)) 
            ((or (= 3 (vlax-get obj 'Type)) (= 2 (vlax-get obj 'Type))) 
              (TraceType23Pline obj)) 
            ((= 1 (vlax-get obj 'Type)) 
              (TraceType1Pline obj)))) 
       ((eq typ "AcDbLine")(TraceLine obj)) 
       ((or (eq typ "AcDbCircle") (eq typ "AcDbArc") (eq typ "AcDbEllipse")) 
         (TraceACE obj)) 
       ((eq typ "AcDbSpline")(TraceSpline obj)) 
       ((eq typ "AcDb3dPolyline")(Trace3DPline obj)) 
    ))) 
(vl-load-com) 
  (setq en (car(entsel "\nУкажите контур: "))) 
  (if (and en (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE,SPLINE,CIRCLE,ARC,ELLIPSE")) 
    (progn 
      (setq lst (TraceObject (vlax-ename->vla-object en))) 
      (lib:Zoom2Lst lst);_Гарантированно полилиния на экране 
      (setq lst (mapcar '(lambda(x)(trans x 0 1)) lst)) 
      (setq lst (mapcar '(lambda(x)(list (car x)(cadr x))) lst)) 
(if (setq ss (ssget opt lst))(SSSETFIRST ss ss)) 
(setq ss nil)))(princ)) 
;_Select Contour Window Polygon 
(defun C:SCWP ()(SelectContour "_WP")) 
;_Select Contour Crossing Polygon 
(defun C:SCCP ()(SelectContour "_CP")) 
(princ "\nНаберите в командной строке SCWP или SCCP")

[Pain]

Большое спасибо что откликнулись))!!
Группы здесь скорее всего не подойдут потому-то они постоянно могут изменятся. В качестве примера вылежал фрагмент расселения, на карте 2 зоны пересекающие друг друга…..и мне нужна такая вещ…При выделении синей или зеленой полилинии должны выделятся ТОЛЬКО все красные точки попавшие в ее контуры. про wpolygon я знаю это немного другое мне нужна именно линия отображающаяся на чертеже а не многоугольный курсор, причем я должен при желании изменить форму или переместить эту линию и соответственно точки попавшие в контур станут другие. Незнаю на сколько всё это решаемо, жду ваших комментариев. Заранее спасибо)
[ATTACH]1161695004.jpg[/ATTACH]

[{Smirnoff}]

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

Код:

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

(defun c:pbsel(/ polyBound vlaPoly utilObj ordLst
         Index curOrd stopFlag blSet curVar
	 filLst)

  (vl-load-com)
  (if
    (not
      (and
	(setq polyBound
         (entsel "\nSelect boundary polyline > "))
     (= "AcDbPolyline"
      (vla-get-Objectname
       (setq vlaPoly
        (vlax-ename->vla-object (car polyBound)))))
	); end not
      ); end and
    (progn
      (princ "\n+++ It's not LWPolyline +++ ")
      (setq vlaPoly nil)
      ); end progn
    ); end if
  (if vlaPoly(vla-Highlight vlaPoly :vlax-true))
    (if
    (not
      (and vlaPoly
	   (setq samBl
	    (entsel "\nSelect Block Reference >"))
     (= "INSERT"
	(cdr(assoc 0(setq dxfLst(entget(car samBl))))))
       ); end and
      ); end not
    (progn
      (princ "\n+++ It's not Block Reference +++ ")
      (setq samBl nil)
      ); end progn
    ); end if
  (if vlaPoly(vla-Highlight vlaPoly :vlax-false))
  (if(and vlaPoly samBl)
    (progn
    (setq utilObj(vla-get-Utility
       (vla-get-ActiveDocument
         (vlax-get-acad-object)))
    ordLst '()
    Index 0
    filLst(vl-remove-if
	    '(lambda(x)(not(member(car x) '(0 2))))dxfLst)
    ); end setq
    (while(not stopFlag)
 (if
  (not
    (vl-catch-all-error-p
      (setq curOrd (vl-catch-all-apply
        'vla-get-Coordinate(list vlaPoly Index)))))
  (progn
    (setq curOrd
	   (append
	     (vlax-safearray->list
	       (vlax-variant-value curOrd))
	        (list(vla-Get-Elevation vlaPoly))))
    (setq curVar(vlax-make-safearray 5 '(0 . 2)))
    (vlax-safearray-fill curVar curOrd)
    (setq curOrd(vlax-make-variant curVar))
    (setq ordLst
     (append ordLst
       (list
       (vlax-safearray->list
         (vlax-variant-value
           (vla-TranslateCoordinates utilObj
              curOrd acOCS acUCS :vlax-false
	       (vla-get-Normal vlaPoly))))
       ); end list
       ); end append
    ); end setq
    ); end progn
  (setq stopFlag T)
  ); end if
      (setq Index(1+ Index))
      ); end while
    (if
      (setq blSet
       (ssget "_CP" ordLst filLst))
      (progn
	(sssetfirst nil blSet)
	(princ
	  (strcat "\n$$$ "
		  (itoa(sslength blSet))
		  " Block References were selected $$$ "))
	); end progn
      (princ "\n+++ No Block References found inside boundary. +++")
      ); end if
  ); end progn
      ); end if
  (princ)
); end of c:pbsel

Если нужно выбирать также пересекаемые блоки см. постинг VVA.

[skkkk]

VVA, #4:
Диалог текстового окна

Код:

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

Команда: SPL

Укажите полилинию: ; ошибка: no function definition: DTR

[skkkk]

Тут есть рабочий лисп на эту тему от VVA (корректно второе издание, переработанное и дополненное).
Мне, например, надо выделять объекты в области контура (замкнутого, разумеется) точь-в-точь, т.е., именно то, что находится внутри контура, ни больше ни меньше... Лисп же с этой ссылки делает чуть не так. Команда SCWP выделяет только объекты, целиком попавшие в контур, при этом игнорируются те, что находятся по обе стороны контура. А команда SCCP выделяет все те, хотя бы часть которых попала в контур. Лиспом, точнее командой BreakTouching отсюда я разрываю все граничащие с контуром линии. Потом делаю Offset (Подобие) секущего контура внутрь на 0,1мм с удалением исходного секущего контура, и выделяю то, что внутри контура командой SCCP, либо наоборот, Offset наружу и командой SCWP. Подобие нужно потому, как я понял, что наш секущий контур после разрыва всех линий касается этих линий как внутри, так и снаружи себя, что нежелательно в моем случае при использовании ни SCCP, ни SCWP. В принципе, это выход, но очень много манипуляций. Может, можно как-то выбирать объекты внутри контура с их разрывом одной командой?

P.S. Изначально хотел, просто донести информацию до кого-то, кому это может пригодиться, но если кто подскажет, как упростить процесс, буду благодарен, хотя и так труда особого не составляет. Вчера коллегу удивил, вырезав из большой карты круглый фрагмент за пятнадцать секунд..... Она break'ом все линии рвала, потом выделяла по одной

[VVA]

skkkk, Добавил в #4 dtr (так, для порядку). SCWP и SCCP лучше (обрабатывают дуговые сегменты). Ты все правильно понял и правильно делаешь. В BreakTouching, по-моему, можно вызвать разрыв функцией, но это нужно смотреть.

[skkkk]

Может, и здесь этот лиспик разместить, раз он лучше?

[skkkk]

Вот еще идея возникла написать макрос на кнопку. С BreakTouching и SCWP все понятно, но как с Offset'ом быть? Как объяснить машине программно, что мне надо сделать Offset внутрь, например, на 0,1?

[VVA]

Это самое сложное, проще наверное попросить пользователя "ткнуть" мышкой. Как вариант - преобразовать в регион и взять центр тяжести.

[skkkk]

VVA,

...преобразовать в регион и взять центр тяжести.

Для меня это звучит подобно следующему:

Индексация финансовых сигригенций зависит от латентоадекватных мажеритарных абструкций.(с)М. Задорнов

[VVA]

Кое-то про склеивание BreakTouching + SCСP + Offset
здесь

[skkkk]

Фрагмент чертежа по прямоуг. или кругл. границе
Хотя, пожалуй лучше опубликую тут - ссылки иногда теряются:

Код:

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

;|==================================================== 
Фрагмент чертежа по прямоуг. или кругл. границе 
(программа тестировалась на 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) 
)

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

skkkk, ссылочку-то подправь. Она в имеющемся виде ведет в никуда

[Olga_@@@]

Pain, задача легко решается в Autodesk Map с помощью запросов.

[Хмурый]

Olga_@@@, Pain отвалил от этого вопроса 2,5 года назад

[Olga_@@@]

Хмурый, и слава богу.
Но, тему не я реанемировала.

[VVA]

Есть еще хороший лисп CookieCutter2 - more fun with ET extrim
Описание

Along the lines of improving on antiquated ExpressTools commands here's CookieCutter2. From the header comments: ;; What does CC2 do which ExpressTools extrim, AKA CookieCutter, doesn't? ;; Works with blocks, hatches and regions by exploding them. ;; Other object types which cannot be trimmed are left intact. ;; Works with objects which do not use a Continuous linetype. ;; Offers an option to delete all objects on visible layers either ;; inside or outside the selected trim object. Read the header comments for more info. The shortcut is CC. Hope you like it.

Краткий перевод: Короткая команда CC. Вырезает из чертежа фрагмент (внутренний или внешний) по выбранному контуру (С подрезкой блоков и т.п.)
Так как там требуется регистрация, то лисп тоже размещу здесь

PS. Еще версия http://forum.dwg.ru/showthread.php?t=42985