获得选择集的最外边界轮廓
本帖最后由 newer 于 2017-2-11 13:39 编辑http://www.cadtutor.net/forum/attachment.php?attachmentid=5779&stc=1&d=1210232873
(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
;http://www.theswamp.org/index.php?topic=15123.0
;;;(defun GetBoundingBox-3d (pt_lst)
;;;(list (apply 'mapcar (cons 'min pt_lst))
;;; (apply 'mapcar (cons 'max pt_lst))
;;;)
;;;)
; ! ***********************************************************
;; ! 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
)
)
;External contour of objects
(defun C:ECO (/ *error* blk obj MinPt MaxPt hiden
pt pl unnamed_block isRus tmp_blk adoc
blks lays lay oname sel csp loc
sc ec ret DS osm iNSpT
)
(defun *error* (msg)
(princ msg)
(mapcar '(lambda (x) (vla-put-Visible x :vlax-true)) hiden)
(vla-endundomark adoc)
(if (and tmp_blk
(not (vlax-erased-p tmp_blk))
(vlax-write-enabled-p tmp_blk)
)
(vla-Erase tmp_blk)
)
(if osm
(setvar "OSMODE" osm)
)
(foreach x loc (vla-put-lock x :vlax-true))
)
(vl-load-com)
(setvar "CMDECHO" 0)
(setq osm (getvar "OSMODE"))
(if (zerop (getvar "WORLDUCS"))
(progn (vl-cmdf "_.UCS" "") (vl-cmdf "_.Plan" ""))
)
(setq isRus (= (getvar "SysCodePage") "ANSI_1251"))
(setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))
blks (vla-get-blocks adoc)
lays (vla-get-layers adoc)
)
(vla-startundomark adoc)
(if isRus
(princ
"\nВыберите объекты для построения контура"
)
(princ "\nSelect objects for making a contour")
)
(vlax-for lay lays
(if (= (vla-get-lock lay) :vlax-true)
(progn (vla-put-lock lay :vlax-false)
(setq loc (cons lay loc))
)
)
)
(if (setq sel (ssget))
(progn
(setq sel (ssnamex sel))
;;; (setq iNSpT(apply 'mapcar (cons 'min
;;; (mapcar 'cadr (apply 'append (mapcar '(lambda(x)(vl-remove-if-not 'listp x)) sel))))))
(setq iNSpT '(0 0 0))
(setq sel (mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr sel))
)
)
(setq csp (vla-objectidtoobject adoc (vla-get-ownerid (car sel))))
; (setq unnamed_block (vla-add (vla-get-blocks adoc)(vlax-3d-point '(0. 0. 0.)) "*U"))
(setq unnamed_block
(vla-add (vla-get-blocks adoc)
(vlax-3d-point inspt)
"*U"
)
)
(foreach x sel
(setq oname (strcase (vla-get-objectname x)))
(cond ((member oname
'("ACDBVIEWPORT"
"ACDBATTRIBUTEDEFINITION"
"ACDBMTEXT"
"ACDBTEXT"
)
)
nil
)
((= oname "ACDBBLOCKREFERENCE")
(vla-InsertBlock
unnamed_block
(vla-get-insertionpoint x)
(vla-get-name x)
(vla-get-xscalefactor x)
(vla-get-yscalefactor x)
(vla-get-zscalefactor x)
(vla-get-rotation x)
)
(setq blk (cons x blk))
)
(t (setq obj (cons x obj)))
)
) ;_foreach
(setq lay (vla-item lays (getvar "CLAYER")))
(if (= (vla-get-lock lay) :vlax-true)
(progn (vla-put-lock lay :vlax-false)
(setq loc (cons lay loc))
)
)
(if obj
(progn (vla-copyobjects
(vla-get-activedocument (vlax-get-acad-object))
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length obj)))
)
obj
)
)
unnamed_block
)
)
)
(setq obj (append obj blk))
(if obj
(progn
;(setq tmp_blk (vla-insertblock csp (vlax-3d-point '(0. 0. 0.))(vla-get-name unnamed_block) 1.0 1.0 1.0 0.0))
(setq tmp_blk (vla-insertblock
csp
(vlax-3d-point inspt)
(vla-get-name unnamed_block)
1.0
1.0
1.0
0.0
)
)
(vla-GetBoundingBox tmp_blk 'MinPt 'MaxPt) ;_Границы блока
(setq MinPt (vlax-safearray->list MinPt)
MaxPt (vlax-safearray->list MaxPt)
DS (max (distance MinPt (list (car MinPt) (cadr MaxPt)))
(distance MinPt (list (car MaxPt) (cadr MinPt)))
)
DS (* 0.2 DS) ;1/5
DS (max DS 10)
MinPt (mapcar '- MinPt (list DS DS))
MaxPt (mapcar '+ MaxPt (list DS DS))
)
(lib:Zoom2Lst (list MinPt MaxPt))
(setq sset (ssget "_C" MinPt MaxPt))
(if sset
(progn
(setvar "OSMODE" 0)
(setq hiden (mapcar 'vlax-ename->vla-object
(vl-remove-if
'listp
(mapcar 'cadr (ssnamex sset))
)
)
hiden (vl-remove tmp_blk hiden)
)
(mapcar '(lambda (x) (vla-put-Visible x :vlax-false))
hiden
)
(setq pt (mapcar '+ MinPt (list (* 0.5 DS) (* 0.5 DS))))
(vl-cmdf "_.RECTANG" (trans MinPt 0 1) (trans MaxPt 0 1))
(setq pl (vlax-ename->vla-object (entlast)))
(setq sc (1- (vla-get-count csp)))
(if
(VL-CATCH-ALL-ERROR-P
(VL-CATCH-ALL-APPLY
'(lambda ()
(vl-cmdf "_-BOUNDARY" (trans pt 0 1) "")
(while (> (getvar "CMDACTIVE") 0) (command ""))
)
)
)
(if isRus
(princ
"\nНе удалось построить контур"
)
(princ "\nIt was not possible to construct a contour")
)
)
(setq ec (vla-get-count csp))
(while (< sc ec)
(setq ret (append ret (list (vla-item csp sc)))
sc(1+ sc)
)
)
(setq ret (vl-remove pl ret))
(mapcar '(lambda (x) (vla-Erase x) (vlax-release-object x))
(list pl tmp_blk)
)
(setq pl nil
tmp_blk nil
)
(setq
ret (mapcar '(lambda (x / mipt)
(vla-GetBoundingBox x 'MiPt nil) ;_Границы блока
(setq MiPt (vlax-safearray->list MiPt))
(list MiPt x)
)
ret
)
)
(setq ret (vl-sort ret
'(lambda (e1 e2)
(< (distance MinPt (car e1))
(distance MinPt (car e2))
)
)
)
)
(setq pl (nth 1 ret)
ret (vl-remove pl ret)
)
(mapcar 'vla-erase (mapcar 'cadr ret))
(mapcar '(lambda (x) (vla-put-Visible x :vlax-true))
hiden
)
(foreach x loc (vla-put-lock x :vlax-true))
(if pl
(progn
(initget "Yes No")
(if
(=
(getkword
(if isRus
"\nУдалять объекты? <No> : "
"\nDelete objects? <No> : "
)
)
"Yes"
)
(mapcar '(lambda (x)
(if (vlax-write-enabled-p x)
(vla-Erase x)
)
)
obj
)
)
)
(if isRus
(princ
"\nНе удалось построить контур"
)
(princ "\nIt was not possible to construct a contour")
)
)
)
)
)
)
(VL-CATCH-ALL-APPLY
'(lambda ()
(mapcar 'vlax-release-object
(list unnamed_block tmp_blk csp blks lays)
)
)
)
)
) ;_if not
(foreach x loc (vla-put-lock x :vlax-true))
(setvar "OSMODE" osm)
(vla-endundomark adoc)
(vlax-release-object adoc)
(princ)
)
函数 lib:IsPtInView**** Hidden Message *****
感谢 N版 分享程序!!!! 仅对曲线有效？如果包含块呢？ liuyj 发表于 2017-2-11 17:50
((= oname "ACDBBLOCKREFERENCE")
(vla-InsertBlock
unnamed_block
(vla-get-insertionpoint x)
(vla-get-name x)
(vla-get-xscalefactor x)
(vla-get-yscalefactor x)
(vla-get-zscalefactor x)
(vla-get-rotation x)
)
(setq blk (cons x blk))
)
代码里面包括了块的处理 {:1_2:}正需要，支持楼主大人了！ 这个太好了，非常感谢"newer"版主！ 看看什么 好东西
啥也不说了，感谢楼主分享哇！ 啥也不说了，感谢楼主分享哇！ 回复学习学习！ 这个东东好 感谢 大师傅的分享
功能强大，很不错。感谢分享。 感谢楼主无私分享 感谢 N版 分享程序!!!!