面域转多段线

jpg102329 · 发表于 2017-8-16 15:25

本帖最后由 jpg102329 于 2017-8-21 08:11 编辑

;除spline转的面域
;16:39 2017/7/28
【唐僧】晗子轩(515357067) 16:38:49
;;;函数名称:SWH-ent-region->curve
;;;函数说明:面域转多段线
;;;参数:lst:面域选择集(可以是多个面域模式)
;;;返回值:转换后的图元名lst
;;;示例setq bbb(SWH-ent-region->curve (setq lst(ssget))))
(defun SWH-ent-region->curve (lst / cl lastent lste lt:ss-entnext objl ss ss->ents ssc swh-select-ss->ents)
;;125.2 [功能] 获取在图元 en 之后产生的图元的选择集--by黄大师
(defun lt:ss-entnext (en / ss)
(if en
(progn
(setq ss (ssadd))
(while (setq en (entnext en))
(if (not (member (cdr (assoc 0 (entget en)))
'("ATTRIB"
"VERTEX"
"SEQEND"
)
)
)
(ssadd en ss)
)
)
(cond((zerop (sslength ss)) (setq ss nil)))
ss
)
(ssget "_x")
)
)
(defun SWH-select-ss->ents (ss / el i sl)
(setq
sl (sslength ss)
i -1
)
(repeat sl
(setq el (cons (ssname ss (setq i (1+ i))) el))
)
el
)
(setq lastent(entlast))
(setq ss (ssadd))
(setq ssc(ssadd))
(if (= (type lst) 'PICKSET)
(setq lste (SWH-select-ss->ents lst))
)
(setq
cl (mapcar
'(lambda (a)
(mapcar 'vlax-vla-object->ename(safearray-value (variant-value a)))
)
(mapcar'vla-explode
(mapcar
'vlax-ename->vla-object
(vl-remove-if'(lambda (x) (/= (cdr (assoc 0 (entget x))) "REGION"))lste)
)
)
)
)
(foreach x cl(foreach y x (ssadd y ss)))
(vl-cmdf "EDIT" "m" ss "" "Y" "J" 0 "")
(setq ssc(SWH-select-ss->ents(lt:ss-entnext lastent)))
)

;除spline转的面域 
;16:39 2017/7/28 
【唐僧】晗子轩(515357067) 16:38:49 
;;;函数名称:SWH-ent-region->curve 
;;;函数说明:面域转多段线 
;;;参    数:lst:面域选择集(可以是多个面域模式) 
;;;返 回 值:转换后的图元名lst 
;;;示    例<img src="static/image/smiley/default/sad.gif" smilieid="2" border="0" alt="" />setq bbb(SWH-ent-region->curve (setq lst(ssget)))) 
(defun SWH-ent-region->curve (lst / cl lastent lste lt:ss-entnext objl ss ss->ents ssc swh-select-ss->ents) 
;;125.2 [功能] 获取在图元 en 之后产生的图元的选择集--by黄大师 
(defun lt:ss-entnext (en / ss) 
(if en 
(progn 
(setq ss (ssadd)) 
(while (setq en (entnext en)) 
(if (not (member (cdr (assoc 0 (entget en))) 
 '("ATTRIB" 
"VERTEX" 
"SEQEND" 
) 
 ) 
) 
(ssadd en ss) 
) 
) 
(cond((zerop (sslength ss)) (setq ss nil))) 
ss 
) 
(ssget "_x") 
) 
) 
  (defun SWH-select-ss->ents (ss / el i sl) 
    (setq 
sl (sslength ss) 
i  -1 
    ) 
    (repeat sl 
      (setq el (cons (ssname ss (setq i (1+ i))) el)) 
    ) 
    el 
  ) 
(setq lastent(entlast)) 
  (setq ss (ssadd)) 
(setq ssc(ssadd)) 
  (if (= (type lst) 'PICKSET) 
    (setq lste (SWH-select-ss->ents lst)) 
  ) 
  (setq 
    cl (mapcar 
         '(lambda (a) 
            (mapcar 'vlax-vla-object->ename(safearray-value (variant-value a))) 
          ) 
         (mapcar'vla-explode 
           (mapcar 
             'vlax-ename->vla-object 
             (vl-remove-if'(lambda (x) (/= (cdr (assoc 0 (entget x))) "REGION"))lste) 
           ) 
         ) 
       ) 
  ) 
  (foreach x cl(foreach y x (ssadd y ss))) 
(vl-cmdf "<img src="static/image/smiley/default/titter.gif" smilieid="9" border="0" alt="" />EDIT" "m" ss "" "Y" "J" 0 "") 
(setq ssc(SWH-select-ss->ents(lt:ss-entnext lastent))) 
)

<以上内容出自《大海语录》不代表本人观点>

欢迎加入通信管线设计技术交流群655280537，通信管线规划设计技术、资源交流群，CAD底图交换、付费教程免费获取、交流经验、互相学习，共同进步！

刘玉良 · 发表于 2018-3-5 14:16

改成这样
(defun C:RTP()
(setq S0 (entsel "\n请点选目标对象:"))
(COMMAND "layer" "n" "defpoints" "c" "7" "defpoints" "s" "defpoints" "p" "p" "defpoints" "" "chprop" S0 "" "la" "defpoints" "")
(COMMAND "EXPLODE" S0 "")
(setq RSS (ssget "x" '((0 . "LINE,ARC,*POLYLINE")(8 . "defpoints"))))
(COMMAND "PEDIT" "M" RSS "" "Y" "J" "0" ""))

比n还多 · 发表于 2018-2-7 15:31

(defun C:RTP()
(setq S0 (entsel "\n请点选目标对象:"))
(COMMAND "layer" "n" "defpoints" "c" "7" "defpoints" "s" "defpoints" "p" "p" "defpoints" "" "chprop" S0 "" "la" "defpoints" "")
(COMMAND "EXPLODE" S0 "")
(setq RSS (ssget "x" '((0 . "LINE,ARC,*POLYLINE")(8 . "defpoints"))))
(COMMAND "PEDIT" "M" RSS "" "Y" "J" "0" "")）

yansu · 发表于 2018-2-9 14:43

win8.1，64位cad2012楼上的两个程序都提示命令: ; 错误: 输入的列表有缺陷

434939575 · 发表于 2017-8-26 20:25

大师怎么2007运行炸开了

1028882406@qq.c · 发表于 2017-8-27 15:47

谢谢楼主，支持下

LIULISHENG · 发表于 2017-9-23 17:57

真的有用处啊

lioun4105 · 发表于 2017-11-25 23:59

好东西，谢谢

逍遥天下 · 发表于 2017-11-26 19:09

路过，顶顶顶

半夜星星 · 发表于 2018-2-4 11:16

怎么出错了啊

比n还多 · 发表于 2018-2-6 21:10

太长了，明天把我的发来看看

账号		自动登录	找回密码
密码			注册