设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 发一个TRIM工具,主要是自动选择修剪对象,
返回列表 发新帖
查看: 2587|回复: 6

发一个TRIM工具,主要是自动选择修剪对象,

[复制链接]
luoyaya
发表于 2003-12-27 11:55:00 | 显示全部楼层 |阅读模式
希望大家帮我完善一下,看看有没有什么不好的地方
  2. (if  (= (getvar "acadver") "14.0" )
  3.   (setq cadver 14)
  4.   (setq cadver 15)
  5.   )
  6. (if (= cadver 15) (vl-load-com))

  8. (defun getunlocklayer(/ layer lay_list )
  9. (setq layer (tblnext "layer" T))
  10.   (if (= (cdr (assoc 70 layer) ) 0)
  11. (setq lay_list (list (cons 8 (cdr (assoc 2 layer)))))
  12.     )
  13. (setq layer (tblnext "layer"))
  14. (while layer
  15.   (if (= (cdr (assoc 70 layer) ) 0)
  16.      (setq lay_list (append lay_list (list (cons 8 (cdr (assoc 2 layer))))))
  17.     )
  18.         (setq layer (tblnext "layer"))
  19.          )
  20.    (append (cons (cons -4  "<OR") lay_list) (list (cons -4  "OR>")))

  22.   )


  25. (setq trss nil)



  29. (defun c:tr ( /  ss ssx i entlist pointlist entpointlist getpo minx miny maxx maxy entlen
  30. objtype minp maxp sstemp sslen entlent distentlist distlist listlen dist
  31. trimobj trss
  32. )
  33.   (defun pointatrec ( point rec / minx miny maxx maxy   )
  34.     (setq minx (min (car (car rec)) (car (cadr rec)) (car (caddr rec)) (car (caddr rec))))
  35.     (setq maxx (max (car (car rec)) (car (cadr rec)) (car (caddr rec)) (car (caddr rec))))
  36.     (setq miny (min (cadr (car rec)) (cadr (cadr rec)) (cadr (caddr rec)) (cadr (caddr rec))))
  37.     (setq maxy (max (cadr (car rec)) (cadr (cadr rec)) (cadr (caddr rec)) (cadr (caddr rec))))
  38.     (if (and (>= (car point) minx) (<= (car point) maxx) (>= (cadr point) miny) (<= (cadr point) maxy))
  39.       T
  40.       nil
  41.     )
  42.     )
  43.   (defun getentpointlist( ent reclist / entlist polistok vlaobj )
  44.     (setq entlist (entget ent)
  45.      ;          enttype (cdr (assoc 0 entlist))
  46.           polistok (list)
  47.           vlaobj (vlax-ename->vla-object ent))
  48.     (cond
  49.           ((pointatrec (vlax-curve-getClosestPointTo vlaobj (car reclist)) reclist)
  50.            (setq  polistok (append polistok (list (vlax-curve-getClosestPointTo vlaobj (car reclist))))))
  51.           ((pointatrec (vlax-curve-getClosestPointTo vlaobj (cadr reclist)) reclist)
  52.            (setq  polistok (append polistok (list (vlax-curve-getClosestPointTo vlaobj (cadr reclist))))))
  53.           ((pointatrec (vlax-curve-getClosestPointTo vlaobj (caddr reclist)) reclist)
  54.            (setq  polistok (append polistok (list (vlax-curve-getClosestPointTo vlaobj (caddr reclist))))))
  55.           ((pointatrec (vlax-curve-getClosestPointTo vlaobj (cadddr reclist)) reclist)
  56.            (setq  polistok (append polistok (list (vlax-curve-getClosestPointTo vlaobj (cadddr reclist))))))
  57.            (T nil)
  58.           )
  59.     (if (zerop (length polistok))
  60.       nil
  61.       (append (list ent) polistok)
  62.       )
  63.     )





  69. (princ "\n智能TRIM由luoyaya编制,欢迎访问luoyaya.nease.net\n")
  70.     (princ "\n请用C交叉窗口方式选择对象!")
  71.   (if (setq ss (ssget (getunlocklayer)))
  72.     (progn
  73.   (setq ssx (ssnamex ss ));SSX格式为 ((选择方式ID 图元名 0 多边形选择区ID)
  74.   (setq i (1- (length ssx))) ;        (多边形选择区ID ( 0 点坐标)))
  75.   (setq entlist (list))
  76.   (setq pointlist (list))
  77.   ;(setq ts (getvar "cdate"))
  78.   (while (> i -1)
  79.     (cond
  80.       ((= (car (nth i ssx)) 3)
  81.                           ;                         取SSX中的图元名   取得多边形区ID
  82.        (setq entlist (append  entlist (list (list (last (nth i ssx)) (nth 1 (nth i ssx)))))))
  83.       ((< (car (nth i ssx)) 0)
  84.          (setq pointlist (append pointlist (list (list
  85.                                                    (car (nth i ssx))
  86.                                                    (trans (cadr (cadr (nth i ssx))) 1 0)
  87.                                                    (trans (cadr (caddr (nth i ssx))) 1 0)
  88.                                                    (trans (cadr (cadddr (nth i ssx))) 1 0)
  89.                                                    (trans (cadr (last (nth i ssx))) 1 0)
  90.                                                    )
  91.                                                  )
  92.                                  )
  93.                )
  94.        )
  95.       (T nil)
  96.       )
  97.     (setq i (1- i))
  98.     )
  99.   (if (zerop (length entlist))
  100.     (princ "\n请用C交叉窗口方式选择对象!")
  101.     (progn
  102.       (setq i (1- (length entlist)))
  103.       (setq entpointlist nil)
  104.       (while (> i -1)
  105.         (if (setq getpo (getentpointlist (cadr (nth i entlist)) (cdr (assoc (car (nth i entlist)) pointlist))))
  106.         (setq entpointlist (append
  107.                              entpointlist
  108.                              (list
  109.                                getpo
  110.                                )
  111.                              )
  112.               );生成一个(被选中的对象中的端点   对象图元名)的表
  113.           )
  114.         (setq i (1- i))
  115.         );第一步完成
  116. ;(setq te (getvar "cdate") tt (* 1000000 (- te ts)))
  117. ;(princ (strcat "\n第一步完成了.共耗时"(rtos tt 2 4) "秒..."))



  121. (setq entlen (1- (length entpointlist)))
  122.       (setq ssa (ssadd))
  123.       (setq objtype '((-4 . "<OR") (0 . "LINE") (0 . "CIRCLE") (0 . "ellipse") (0 . "ARC") (0 . "SPLINE") (0 . "LWPOLYLINE") (-4 . "OR>")))
  124.    (while (> entlen -1)
  125.      (vla-getboundingbox
  126.        (vlax-ename->vla-object (car (nth entlen entpointlist)))       'minp       'maxp
  127.      )
  128.      (if (= cadver 15)
  129.        (setq minp        (vlax-safearray->list minp)
  130.            maxp        (vlax-safearray->list maxp)
  131.      ))   ;for 200X
  132.      (if (setq sstemp (ssget "c" minp maxp  objtype  ))
  133.       (progn
  134.         (setq i (1- (sslength sstemp)))
  135.        (while (> i -1)
  136.        (setq ssa (ssadd (ssname sstemp i ) ssa ))
  137.        (setq i (1- i))
  138.        )
  139.         )
  140.                       )
  141.      (setq entlen (1- entlen))
  142.    )




  147.      
  148.        
  149. ;(setq te (getvar "cdate") tt (* 1000000 (- te ts)))
  150. ;(princ (strcat "\n第二步完成了.共耗时"(rtos tt 2 4) "秒..."))


  153.       
  154.       ;开始选择TRIM的对象
  155.        ;(setq ssa (ssget "c" (list minx miny) (list maxx maxy)   '((-4 . "<OR") (0 . "LINE") (0 . "CIRCLE") (0 . "ellipse") (0 . "ARC") (0 . "SPLINE") (0 . "LWPOLYLINE") (-4 . "OR>")) ))
  156.         
  157.         (setq sslen (1- (sslength ss)))
  158.       (while (> sslen -1)
  159.         (if (setq sstemp (ssdel (ssname  ss sslen) ssa))
  160.           (setq ssa sstemp)
  161.           )
  162.         (setq sslen (1- sslen))
  163.         )
  164.         (if (not (zerop  (sslength ssa)))
  165.           (progn

  167.       
  168. ;判断SSA中对象和ENTPOINTLIST中对象是否有交点
  169.      (setq sslen (1- (sslength ssa))
  170.             entlen (1- (length entpointlist))
  171.             entlent entlen
  172.             sstemp ssa
  173.             ssa (ssadd))
  174.      (if (= cadver 15)
  175.                 (progn
  176.       (while (> sslen -1)
  177.         (while (> entlen -1)
  178.         (if (not (vl-catch-all-error-p
  179.               (vl-catch-all-apply 'vlax-safearray->list
  180.                 (list (vlax-variant-value (vla-IntersectWith
  181.                                             (vlax-ename->vla-object (ssname sstemp sslen))
  182.                                             (vlax-ename->vla-object (car (nth entlen entpointlist)))
  183.                                             0
  184.                                             )
  185.                         )
  186.                       )
  187.                 )
  188.               ))
  189.           (setq ssa (ssadd (ssname sstemp sslen) ssa)
  190.                 ;sslen (1- sslen)
  191.                 entlen -1)
  192.           )
  193.           
  194.           ;(setq ssa (ssdel (ssname ssa sslen) ssa)
  195.         ;        sslen (1- sslen)
  196.         ;        entlen entlent)
  197.           
  198.           ;(if (< sslen 0)(setq entlen -2))
  199.           (setq entlen (1- entlen))
  200.           )
  201.         (setq sslen (1- sslen)
  202.               entlen entlent)
  203.         ))
  204.        (progn
  205.       (while (> sslen -1)
  206.         (while (> entlen -1)
  207.         (if (vla-IntersectWith    (vlax-ename->vla-object (ssname sstemp sslen))
  208.                                   (vlax-ename->vla-object (car (nth entlen entpointlist)))
  209.                                             0
  210.                                             )             
  211.           (setq ssa (ssadd (ssname sstemp sslen) ssa)
  212.                 ;sslen (1- sslen)
  213.                 entlen -1)
  214.           )
  215.           
  216.           ;(setq ssa (ssdel (ssname ssa sslen) ssa)
  217.         ;        sslen (1- sslen)
  218.         ;        entlen entlent)
  219.           
  220.           ;(if (< sslen 0)(setq entlen -2))
  221.           (setq entlen (1- entlen))
  222.           )
  223.         (setq sslen (1- sslen)
  224.               entlen entlent)
  225.         ))
  226.        )


  229.     ;  (setq te (getvar "cdate") tt (* 1000000 (- te ts)))
  230. ;(princ (strcat "\n第三步完成了.共耗时"(rtos tt 2 4) "秒..."))


  233.       
  234.       (setq sslen (1- (sslength ssa)));取得SS个数
  235.       (if (> sslen 500)
  236.         (progn
  237.           (if (member (getstring (strcat "自动选择的对象有"
  238.                                          (vl-princ-to-string sslen)
  239.                                          "个,是否自己选择?y/n[y]"
  240.                                  )
  241.                       )
  242.                       '("n" "N")
  243.               )
  244.             (progn
  245.               (setq distentlist
  246.                      (list)
  247.                     distlist (list)
  248.               )
  249.               (while (> sslen -1)
  250.                 (setq listlen (1- (length entpointlist)))
  251.                 (setq dist -1)
  252.                 (while (> listlen -1)
  253.                   (if (= dist -1)
  254.                     (setq dist 0)
  255.                   )
  256.                   (setq        dist
  257.                          (+ (distance
  258.                               (vlax-curve-getClosestPointTo
  259.                                 (vlax-ename->vla-object (ssname ssa sslen))
  260.                                 (cadr (nth listlen entpointlist))
  261.                               )
  262.                               (cadr (nth listlen entpointlist))
  263.                             )                ;取得ENTPOINTLIST中点与SSa中线的距离
  264.                             dist
  265.                          )
  266.                   )


  269.                   (setq listlen (1- listlen))
  270.                 )
  271.                 (if (/= dist -1)
  272.                   (setq        distentlist (append
  273.                                       distentlist
  274.                                       (list (list dist (ssname ssa sslen)))
  275.                                     )
  276.                         distlist    (append distlist (list dist))
  277.                   )
  278.                 )
  279.                 (setq sslen (1- sslen))
  280.               )

  282.               (setq trimobj
  283.                      (cadr (assoc (apply 'min distlist) distentlist))
  284.                     ;trimobjcopy trimobj
  285.               )                        ;查找最近的线


  288.               (redraw trimobj 3)        ;亮显最近的线
  289.               (princ "\n如果不是这条剪切边请选择,如果是请回车:")

  291.               (setq trss (ssget))
  292.               (redraw trimobj 4)        ;不亮显最近的线
  293.               (if (not trss)
  294.                 (setq trss trimobj)
  295.               )
  296.             )
  297.             (progn
  298.               (princ "\n请选择剪切边:")
  299.               (setq trss (ssget))
  300.             )
  301.           )



  305.         )
  306.         (progn
  307.           (setq        distentlist
  308.                  (list)
  309.                 distlist (list)
  310.           )
  311.           (while (> sslen -1)
  312.             (setq listlen (1- (length entpointlist)))
  313.             (setq dist -1)
  314.             (while (> listlen -1)
  315. ;;;;```因entpointlist第一项为nil所以>0
  316.               (if (= dist -1)
  317.                 (setq dist 0)
  318.               )
  319.               (setq dist
  320.                      (+        (distance
  321.                           (vlax-curve-getClosestPointTo
  322.                             (vlax-ename->vla-object (ssname ssa sslen))
  323.                             (cadr (nth listlen entpointlist))
  324.                           )
  325.                           (cadr (nth listlen entpointlist))
  326.                         )                ;取得ENTPOINTLIST中点与SSa中线的距离
  327.                         dist
  328.                      )
  329.               )


  332.               (setq listlen (1- listlen))
  333.             )
  334.             (if        (/= dist -1)
  335.               (setq distentlist        (append        distentlist
  336.                                         (list (list dist (ssname ssa sslen)))
  337.                                 )
  338.                     distlist        (append distlist (list dist))
  339.               )
  340.             )
  341.             (setq sslen (1- sslen))
  342.           )
  343.           (setq
  344.             trimobj (cadr (assoc (apply 'min distlist) distentlist))
  345.           )                                ;查找最近的线



  349.           (if trimobj
  350.             (progn
  351.           (redraw trimobj 3)                ;亮显最近的线
  352.           (princ "\n如果不是这条剪切边请选择,如果是请回车:")

  354.           (setq trss (ssget))
  355.           (redraw trimobj 4)                ;不亮显最近的线
  356.           (if (not trss)
  357.             (setq trss trimobj)
  358.           )
  359.           )
  360.             (progn
  361.             (princ "\n找不到剪切边,请选择:")
  362.         (setq trss (ssget))
  363.             ))
  364.         )
  365.       )


  368. )


  371.        
  372.           
  373.         (progn
  374.         (princ "\n找不到剪切边,请选择:")
  375.         (setq trss (ssget))
  376.         ))
  377.       (if (not trss)
  378.         (princ "\n未选择剪切边,不剪切!")
  379.         (progn
  380.       (command "_.trim" trss "")
  381.       (setq sslen (1- (length entpointlist)))
  382.       (while (> sslen -1)
  383.         (command (nth sslen entpointlist))
  384.         (setq sslen (1- sslen))
  385.       )
  386.       (command)
  387.       ))
  388.       )
  389.   )
  390.   )
  391.     (princ "\n未选择被剪切边!"))
  392.   (princ)
  393.   )
回复

使用道具 举报

luoyaya
 楼主| 发表于 2003-12-27 17:11:00 | 显示全部楼层
用法见图
回复 支持 反对

使用道具 举报

luoyaya
 楼主| 发表于 2003-12-27 17:11:00 | 显示全部楼层
用法见图

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x
回复 支持 反对

使用道具 举报

luoyaya
 楼主| 发表于 2003-12-28 11:50:00 | 显示全部楼层
没人理,惨
回复 支持 反对

使用道具 举报

hzzhao
发表于 2003-12-28 15:03:00 | 显示全部楼层
用不着这么麻烦写这个！AutoCAD本身就有这个功能！在你先择要修剪物体的时候，打F就可以选择多个物体一起修剪。试试。
回复 支持 反对

使用道具 举报

luoyaya
 楼主| 发表于 2003-12-29 14:20:00 | 显示全部楼层
不一样的啊,我这个不用F选用C选,然后是自动选线
回复 支持 反对

使用道具 举报

龙龙仔
发表于 2003-12-30 16:52:00 | 显示全部楼层
再說詳細有甚麼功能好嗎?
(最好能說說思路__看不出為甚麼程序要那麼長!)
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-10-2 06:25 , Processed in 0.202346 second(s), 26 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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