Выделение снаружи _pline

Выделение снаружи _pline · 31.07.2007, 17:40

С помощью ssget можно получить набор примитивов внутри выпуклой полилинии. А как получить набор примитивов находящихся снаружи полилинии, или хотя бы прямоугольника?

VVA · 31.07.2007, 18:03

Например так

Код:

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

(defun C:OCS (  / en ss lst ssall bbox tmp head)
;Выделение снаружи полилинии
;_ http://forum.dwg.ru/showthread.php?t=12899
;Required Express tools
;OutSide Contour Select
(vl-load-com) 
(if (null ACET-GEOM-OBJECT-POINT-LIST)
    (progn
      (alert "Required Express tools!!!")
      (exit)
      )
    )
  (if (and (setq en (car(entsel "\nSelect contour: "))) 
           (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE")) 
    (progn 
      (setq lst (ACET-GEOM-OBJECT-POINT-LIST en 1e-3)) 
      (setq lst (mapcar '(lambda(x)(list (car x)(cadr x))) lst))
      (while lst
        (setq head (car lst)
          tmp (cons head tmp)
          lst (vl-remove-if '(lambda(pt)(equal pt head 1e-6))(cdr lst))
          )
        )
  (setq lst (reverse tmp))
      (if (and 
            (setq ss (ssget "_CP" lst)) 
            (setq ssall (ssget "_X" (list (assoc 410 (entget en))))) 
            (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssall)))) 
            (setq lst (vl-remove-if '(lambda(x)(minusp 
            (cdr(assoc 62 (tblsearch "layer" 
            (cdr(assoc 8 (entget x)))))))) lst)) 
            (setq ssall nil ssall (ACET-LIST-TO-SS lst)) 
           ) 
        (progn 
          (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))) 
          (foreach e1 lst (ssdel e1 ssall)) 
          (SSSETFIRST ssall ssall) 
          ) 
        ) 
      ) 
    ) 
  ) 
(princ "\nType OCS")

но полилиния не должна иметь самопересечений, и необходимо
наличие Express tools

** Исправлено: Выключенные слои
21.01.2009 Обработка криволинейных контуров (удаление дублирующихся точек)

VVA · 31.07.2007, 18:11

Выше быстро переделанный код удаления снаружи полилинии с обрезкой.

Код:

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

(defun C:OCD (  / en ss lst ssall bbox tmp head)
;Удаление снаружи полилинии
;Опубликовано http://forum.dwg.ru/showthread.php?t=12899
;http://forums.augi.com/showthread.php?t=65088&page=3
;Required Express tools
;OutSide Contour Delete
(vl-load-com)
(if (null ACET-GEOM-OBJECT-POINT-LIST)
    (progn
      (alert "Required Express tools!!!")
      (exit)
      )
    )
  (if (and (setq en (car(entsel "\nSelect contour: ")))
           (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE"))
    (progn
      (setq bbox (ACET-ENT-GEOMEXTENTS en))
      (setq bbox (mapcar '(lambda(x)(trans x 0 1)) bbox))
      (setq lst (ACET-GEOM-OBJECT-POINT-LIST en 1e-6))
      (while lst
        (setq head (car lst)
          tmp (cons head tmp)
          lst (vl-remove-if '(lambda(pt)(equal pt head 1e-3))(cdr lst))
          )
        )
      (setq lst (reverse tmp))
      (ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list en)))
      (command "_.Zoom" "0.95x")
      (if (null etrim)(load "extrim.lsp"))
      (etrim en (polar
                  (car bbox)
                  (angle (car bbox)(cadr bbox))
                  (* (distance (car bbox)(cadr bbox)) 1.1)))
      (if (and
            (setq ss (ssget "_CP" lst))
            (setq ssall (ssget "_X" (list (assoc 410 (entget en)))))
           )
        (progn
          (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
          (foreach e1 lst (ssdel e1 ssall))
          (ACET-SS-ENTDEL ssall)
          )
        )
      )
    )
  )
(princ "\nType OCD")

plugin · 31.07.2007, 18:56

Спасибо. Но, к сожалению OCS выделяет все примитивы внутри контура на выключенных слоях.

VVA · 31.07.2007, 19:13

Исправил. См. пост №3

plugin · 31.07.2007, 19:29

Программа OCD из поста 3 данной темы поступает еще более жестоко, она удаляет абсолютно все на выключенных слоях внутри прямоугольника.

Кулик Алексей aka kpblc · 31.07.2007, 22:01

Еще один вариант, достаточно кривой кстати:

Код:

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

(defun c:out (/ ent selset_all selset_in selset_out)
  (vl-load-com)
  (if (and (not (vl-catch-all-error-p
                  (vl-catch-all-apply
                    '(lambda ()
                       (setq ent (car (entsel "\nУкажите контур <Отмена> : ")))
                       ) ;_ end of lambda
                    ) ;_ end of vl-catch-all-apply
                  ) ;_ end of vl-catch-all-error-p
                ) ;_ end of not
           ent
           (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
           (= (logand (cdr (assoc 70 (entget ent))) 129) 1)
           ) ;_ end of and
    (progn
      (setq selset_all (ssget "_X")
            selset_in  (ssget "_WP"
                              (mapcar '(lambda (a) (list (car a) (cadr a) 0.))
                                      (mapcar 'cdr
                                              (vl-remove-if-not
                                                '(lambda (x) (= (car x) 10))
                                                (entget ent)
                                                ) ;_ end of vl-remove-if-not
                                              ) ;_ end of mapcar
                                      ) ;_ end of mapcar
                              ) ;_ end of ssget
            selset_in  (ssadd ent selset_in)
            selset_out (ssadd)
            ) ;_ end of setq
      (foreach item (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset_all)))
        (if (not (ssmemb item selset_in))
          (setq selset_out (ssadd item selset_out))
          ) ;_ end of if
        ) ;_ end of foreach
      ) ;_ end of progn
    ) ;_ end of if
  (sssetfirst selset_out selset_out)
  ) ;_ end of defun

P.S. тестировалось только в мировой системе координат.

plugin · 31.07.2007, 22:16

Уважаемый Владимир! Большое спасибо. После исправлений программа стала работать намного лучше. Но на некоторых файлах все равно выделяются объекты внутри контура.
На прилагаемом чертеже внутри прямоугольника блок на выключенном слое. Подправленная программа OCS к сожалению его выделяет.
[ATTACH]1185905713.dwg[/ATTACH]

Аshаs-ка · 31.07.2007, 22:48

К слову. В китайском-раскитайском ZW-CADе есть опция "выделить все вне рамки"... www.zw-cad.ru

Клякса · 15.08.2007, 23:53

Сорри за вопрос, а можно поподробнее рассказать про функцию ssget? Или ссылку на соответствующий ресурс кинуть.
Заранее благодарен...

Кулик Алексей aka kpblc · 16.08.2007, 00:29

Справку цитировать как-то не гуд... vlide -> F1, а также любая книга Н.Н.Полещука, посвященная AutoLISP и (или) VisualLISP.

Клякса · 16.08.2007, 20:20

Осознал. Большое спасибо. :0)

VVA · 22.08.2007, 15:53

>plugin Команда работает правильно. Блок у тебя неправильный

Сам блок вставлен на включенный слой 0, а внутри него объекты отрисованы на слое 2. Слой 2 выключен, поэтому блока не видно.

Клякса · 22.08.2007, 22:02

А в VB что-нибудь похожее на ssget есть, или самому надо процедурку писать?

Кулик Алексей aka kpblc · 22.08.2007, 23:40

В VBA точно есть. А для VB надо библиотеки подключать либо использовать позднее связывание со всеми вытекающими.

Клякса · 23.08.2007, 21:22

Ок. Будем искать. А акадовские библиотеки по-любому подключать приходится.

VVA · 22.01.2009, 10:34

Вариант кода из #3 без Express'овского extrim'а. Просто удаляет объекы за пределами контура

Код:

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

(defun C:OCD1 (  / en ss lst ssall bbox tmp head)
;Удаление снаружи полилинии
; Необходимо наличие Express tools  
;Опубликовано http://forum.dwg.ru/showthread.php?t=12899
;http://forums.augi.com/showthread.php?t=65088&page=3
;Required Express tools
;OutSide Contour Delete
(vl-load-com)
  (if (null ACET-GEOM-OBJECT-POINT-LIST)
    (progn
      (alert "Необходимо наличие Express Tools!!!")
      (exit)
      )
    )
  (if (and (setq en (car(entsel "\nSelect contour: ")))
           (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE"))
    (progn
      (setq bbox (ACET-ENT-GEOMEXTENTS en))
      (setq bbox (mapcar '(lambda(x)(trans x 0 1)) bbox))
      (setq lst (ACET-GEOM-OBJECT-POINT-LIST en 1e-6))
      (while lst
        (setq head (car lst)
          tmp (cons head tmp)
          lst (vl-remove-if '(lambda(pt)(equal pt head 1e-3))(cdr lst))
          )
        )
      (setq lst (reverse tmp))
      (ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list en)))
      (command "_.Zoom" "0.95x")
      (if (and
            (setq ss (ssget "_CP" lst))
            (setq ssall (ssget "_X" (list (assoc 410 (entget en)))))
           )
        (progn
          (setq tmp '-1)
          (repeat (sslength ss)
            (ssdel (ssname ss (setq tmp (1+ tmp))) ssall)
            )
          (ACET-SS-ENTDEL ssall)
          )
        )
      )
    )
)
(princ "\nType OCD1")

Nike · 09.04.2013, 12:14

Цитата:

Сообщение от VVA

удаляет объекы за пределами контура

Если внутри контура есть видовые экраны, то они удаляются вместе с объектами за пределами.
Можно ли подправить?

VVA · 10.04.2013, 18:25

Nike, Приложи образец. Постараюсь помочь.

sime · 20.05.2013, 18:26

А можно сделать так что бы выбрать несколько контуров и удалить все что снаружи?

Griin · 13.01.2014, 16:20

Цитата:

Сообщение от sime

А можно сделать так что бы выбрать несколько контуров и удалить все что снаружи?

Вот тот-же вопрос. Можно ли этот lisp доработать таким образом?

Олег (jr.) · 13.01.2014, 21:05

Смотри здесь:
http://forums.autodesk.com/t5/Visual...883703#M232901

Griin · 14.01.2014, 10:05

Цитата:

Сообщение от Олег (jr.)

Смотри здесь:
http://forums.autodesk.com/t5/Visual...883703#M232901

Что-то не работает: скопировал, установил, прописываю в командной строке (SelByObj)- а он выдает мне "; ошибка: слишком мало аргументов"

----- добавлено через 27 сек. -----
В чем проблема?

VVA · 14.01.2014, 21:46

Не то взываешь. Там есть команды SSOW и SSOC. Подробнее читай в моей подписи

Griin · 16.01.2014, 17:44

Цитата:

Сообщение от VVA

Там есть команды SSOW и SSOC

Выдает другую ошибку: ; ошибка: неверная строка режима ssget
Вот код, который я скопировал:

Код:

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

 ;;; SelByObj -Gilles Chanteau- 06/10/06
;;; Creates a selection set from an object (circle ellipse or closed
;;; lwpolyline) by Window Polygon or Crossing Polygon.
;;;
;;; Arguments :
;;; - ename
;;; - selection mode (Cp or Wp)
;;; - selection filter or nil

(defun SelByObj (ent opt fltr / obj dist n lst prec dist p_lst)
(vl-load-com)
(if (= (type ent) 'ENAME)
(setq obj (vlax-ename->vla-object ent))
)
(cond
((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))
(setq dist (/ (vlax-curve-getDistAtParam
obj
(vlax-curve-getEndParam obj)
)
50
)
n 0
)
(repeat 50
(setq
lst
(cons
(trans
(vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
0
1
)
lst
)
)
)
)
(T
(setq p_lst (vl-remove-if-not
'(lambda (x)
(or (= (car x) 10)
(= (car x) 42)
)
)
(entget ent)
)
)
(while p_lst
(setq
lst
(append
lst
(list (trans (append (cdr (assoc 10 p_lst))
(list (cdr (assoc 38 (entget ent))))
)
ent
1
)
)
)
)
(if (/= 0 (cdadr p_lst))
(progn
(setq prec (1+ (fix (* 50 (abs (cdadr p_lst)))))
dist (/ (- (if (cdaddr p_lst)
(vlax-curve-getDistAtPoint
obj
(trans (cdaddr p_lst) ent 0)
)
(vlax-curve-getDistAtParam
obj
(vlax-curve-getEndParam obj)
)
)
(vlax-curve-getDistAtPoint
obj
(trans (cdar p_lst) ent 0)
)
)
prec
)
n 0
)
(repeat (1- prec)
(setq
lst (append
lst
(list
(trans
(vlax-curve-getPointAtDist
obj
(+ (vlax-curve-getDistAtPoint
obj
(trans (cdar p_lst) ent 0)
)
(* dist (setq n (1+ n)))
)
)
0
1
)
)
)
)
)
)
)
(setq p_lst (cddr p_lst))
)
)
)
(ssget (strcat "_" opt) lst fltr)
)

;;; Examples (remove space between < and OR or AND):

;;; SSOC Selection by Crossig

(defun c:ssoc (/ ss opt)
(sssetfirst nil nil)
(if (setq ss (ssget "_:smileyfrustrated::E"
(list
'(-4 . "< OR")
'(0 . "CIRCLE")
'(-4 . "< AND")
'(0 . "ELLIPSE")
'(41 . 0.0)
(cons 42 (* 2 pi))
'(-4 . "AND>")
'(-4 . "< AND")
'(0 . "LWPOLYLINE")
'(-4 . "&")
'(70 . 1)
'(-4 . "AND>")
'(-4 . "OR>")
)
)
)
(sssetfirst
nil
(ssdel (ssname ss 0) (SelByObj (ssname ss 0) "Cp" nil))
)
)
(princ)
)

;;; SSOW Selection by Window

(defun c:ssow (/ ss opt)
(sssetfirst nil nil)
(if (setq ss (ssget "_:smileyfrustrated::E"
(list
'(-4 . "< OR")
'(0 . "CIRCLE")
'(-4 . "< AND")
'(0 . "ELLIPSE")
'(41 . 0.0)
(cons 42 (* 2 pi))
'(-4 . "AND>")
'(-4 . "< AND")
'(0 . "LWPOLYLINE")
'(-4 . "&")
'(70 . 1)
'(-4 . "AND>")
'(-4 . "OR>")
)
)
)
(sssetfirst nil (SelByObj (ssname ss 0) "Wp" nil))
)
(princ)
)

;;; Inv_Sel Inverse a selection set

(defun c:inv_sel (/ ssa ssf n e)
(setq ssa (ssget "_A" '((0 . "~VIEWPORT"))))
(if (setq ssf (cadr (ssgetfirst)))
(repeat (setq n (sslength ssa))
(if (ssmemb (setq e (ssname ssa (setq n (1- n)))) ssf)
(ssdel e ssa)
)
)
)
(sssetfirst)
(sssetfirst nil ssa)
(princ)
)

gomer · 16.01.2014, 19:39

Вместо

нужно написать :S

VVA · 16.01.2014, 22:40

Цитата:

Сообщение от gomer

Вместо

нужно написать :S

В коде поста #25 вместо "_:smileyfrustrated::E" должно быть "_:S:E"

skkkk · 17.01.2014, 10:24

ObjectARX для Autocad 2010-2014. Выделение элементов по существующим контурам

Griin · 17.01.2014, 12:47

Цитата:

Сообщение от gomer

Вместо нужно написать :S

Цитата:

Сообщение от VVA

В коде поста #25 вместо "_:smileyfrustrated::E" должно быть "_:S:E"

Сообщение об ошибке исчезло но выделения не происходит.

Цитата:

Сообщение от skkkk

ObjectARX для Autocad 2010-2014. Выделение элементов по существующим контурам

У меня 2008 Autocad

Serhio163 · 26.12.2023, 14:38

Цитата:

Сообщение от VVA

Выше быстро переделанный код удаления снаружи полилинии с обрезкой.

Здравствуйте, помогите пожалуйста дописать код
В модели есть блок "Страница", процедура "Обрезка" находит блок, взрывает его, выбирает из обломков замкнутую полилинию (контур) и устанавливает подрезку растра по этому контуру
За этим мне нужно осуществить обрезку чертежа снаружи по этому же контуру... на VBA ничего не удалось найти, Ваш лисп OCD работает как надо, но с выбором руками контура...
Как можно передать в лисп этот контур?

Код:

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

Sub Обрезка()
Dim ss As AcadSelectionSet
Dim объект As AcadObject
    Dim intType(0) As Integer
    Dim varData(0) As Variant
    
    intType(0) = 410
    varData(0) = "Model"


    Dim AE As AcadEntity

Set ss = SelectAll(intType, varData)
        For Each объект In ss
            On Error Resume Next
            If TypeOf объект Is AcadRasterImage And объект.Name = "растр" Then
                объект.ClippingEnabled = True
                Set AE = КонтурСтраницы("Страница")
                объект.ClipBoundary AE.Coordinates
                
                comStr = "(if (null OCD) (load " & Chr(34) & папка_лисп & "OCD.LSP" & Chr(34) & "))"
                ThisDrawing.SendCommand comStr & vbCr
                ThisDrawing.SendCommand "OCD" & vbCr
                
                'AE.Delete
            End If
        Next объект

End Sub

Код:

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

Public Function КонтурСтраницы(Optional имя_блока As String) As AcadObject
    Dim ss As AcadSelectionSet
    Dim объект As AcadBlockReference 'AcadObject
    Dim dynProps1() As AcadDynamicBlockReferenceProperty
    Dim dynProps2() As AcadDynamicBlockReferenceProperty

    
    Dim страница$
    
    'Создаем набор выбора
    Set ss = CreateSelect(ss, "objects")
    
    Dim intType(3) As Integer
    Dim varData(3) As Variant
    
    'Настраиваем фильтр выбора только блоков в пространстве модели
    intType(0) = -4
    varData(0) = "<AND"
    intType(1) = 410
    varData(1) = "Model"
    intType(2) = 0
    varData(2) = "INSERT"
    intType(3) = -4
    varData(3) = "AND>"
    
    'Создаем набор объектов
    ss.Select acSelectionSetAll, , , intType, varData
    
    'Бежим по набору объектов модели
    If ss.Count > 0 Then
        
        For Each объект In ss
            
            'Если имя блока рамка и штамп, то
            If объект.EffectiveName = имя_блока Then
                ' Взорвем блочную ссылку
                Dim explodedObjects As Variant
                explodedObjects = объект.explode
            ' Перечислим полученные обломки
                Dim Iex As Integer
                For Iex = 0 To UBound(explodedObjects)
                    If Not explodedObjects(Iex).ObjectName = "AcDbPolyline" Then
                        explodedObjects(Iex).Delete
                    Else
                        explodedObjects(Iex).color = acGreen
                        Set КонтурСтраницы = explodedObjects(Iex)

                    End If
                Next
            End If
        Next объект

    Else
        
        ThisDrawing.Utility.Prompt "В модели нет ни такого блока!"

        Exit Function
        
    End If

End Function

31.07.2007, 17:40		#1
Выделение снаружи _pline plugin Москва Регистрация: 09.07.2007 Сообщений: 10 С помощью ssget можно получить набор примитивов внутри выпуклой полилинии. А как получить набор примитивов находящихся снаружи полилинии, или хотя бы прямоугольника?
Просмотров: 16267