设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 2094|回复: 105

[每日一码] 获得选择集的最外边界轮廓

  [复制链接]

签到天数: 1142 天

连续签到: 1 天

[LV.10]以坛为家III

已领礼包: 40个

财富等级: 招财进宝

发表于 2017-2-11 13:34:58 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有帐号?立即注册

x
本帖最后由 newer 于 2017-2-11 13:39 编辑


                               
登录/注册后可看大图


(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
                                        ;[url=http://www.theswamp.org/index.php?topic=15123.0]http://www.theswamp.org/index.php?topic=15123.0[/url]
;;;(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Удалять объекты? [Yes/No] <No> : "
                          "\nDelete objects? [Yes/No] <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
游客,如果您要查看本帖隐藏内容请回复


论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

签到天数: 1935 天

连续签到: 70 天

[LV.Master]伴坛终老I

已领礼包: 5669个

财富等级: 富甲天下

发表于 2017-2-11 14:28:13 | 显示全部楼层
感谢 N版 分享程序!!!!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 1962 天

连续签到: 141 天

[LV.Master]伴坛终老I

已领礼包: 5436个

财富等级: 富甲天下

发表于 2017-2-11 17:50:40 | 显示全部楼层
仅对曲线有效?如果包含块呢?
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 530 天

连续签到: 8 天

[LV.9]以坛为家II

已领礼包: 20个

财富等级: 恭喜发财

发表于 2017-2-11 18:22:54 | 显示全部楼层


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

代码里面包括了块的处理
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 406 天

连续签到: 3 天

[LV.9]以坛为家II

已领礼包: 461个

财富等级: 日进斗金

发表于 2017-2-11 19:36:11 | 显示全部楼层
正需要,支持楼主大人了!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 1920 天

连续签到: 15 天

[LV.Master]伴坛终老I

已领礼包: 5270个

财富等级: 富甲天下

发表于 2017-2-11 19:44:40 | 显示全部楼层
这个太好了,非常感谢"newer"版主!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 740 天

连续签到: 2 天

[LV.9]以坛为家II

已领礼包: 1419个

财富等级: 财源广进

发表于 2017-2-11 21:45:00 | 显示全部楼层
看看什么 好东西
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 998 天

连续签到: 8 天

[LV.10]以坛为家III

已领礼包: 2181个

财富等级: 金玉满堂

发表于 2017-2-11 22:27:29 | 显示全部楼层
啥也不说了,感谢楼主分享哇!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 1990 天

连续签到: 88 天

[LV.Master]伴坛终老I

已领礼包: 5910个

财富等级: 富甲天下

发表于 2017-2-12 00:09:04 | 显示全部楼层
啥也不说了,感谢楼主分享哇!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 1487 天

连续签到: 18 天

[LV.10]以坛为家III

已领礼包: 1957个

财富等级: 堆金积玉

发表于 2017-2-12 09:16:38 | 显示全部楼层
回复学习学习!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 950 天

连续签到: 1 天

[LV.10]以坛为家III

已领礼包: 836个

财富等级: 财运亨通

发表于 2017-2-12 16:10:21 | 显示全部楼层
这个东东好
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 1594 天

连续签到: 51 天

[LV.Master]伴坛终老I

点击这里给我发消息

已领礼包: 4449个

财富等级: 富可敌国

发表于 2017-2-12 19:52:54 | 显示全部楼层
感谢 大师傅的分享
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 172 天

连续签到: 1 天

[LV.7]常住居民III

已领礼包: 312个

财富等级: 日进斗金

发表于 2017-2-12 21:23:31 | 显示全部楼层
功能强大,很不错。感谢分享。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 216 天

连续签到: 1 天

[LV.7]常住居民III

点击这里给我发消息

已领礼包: 85个

财富等级: 招财进宝

发表于 2017-2-12 21:26:26 | 显示全部楼层
感谢楼主无私分享
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 220 天

连续签到: 2 天

[LV.7]常住居民III

点击这里给我发消息

已领礼包: 190个

财富等级: 日进斗金

发表于 2017-2-13 08:17:01 | 显示全部楼层
感谢 N版 分享程序!!!!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|小黑屋|手机版|Archiver|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )  

GMT+8, 2018-10-22 16:57 , Processed in 0.239441 second(s), 62 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表