[日积月累]：修剪穿过 Circle 和 text 的线

lemonx

比晓东工具中的更强！
不过现在只能修剪完全穿过circle的线，对伸入circle内一部分的线无能为力

lhj743

最初由 lemonx 发布
[B]比晓东工具中的更强！
不过现在只能修剪完全穿过circle的线，对伸入circle内一部分的线无能为力 [/B]

的确这样，
对于Mtext也不行！
限制条件太多。
斑竹能不能扩大范围啊？
比如增加多行文字，
任意直线、曲线等！

snoopychen

以前编过一个14版的圆,多边形内的直线批量修剪程序。
由于代码编写比较乱，一直想用vlisp重新写一下。
期间学习
aeo版主的“自动扩展修剪”（利用xdapi）
eachy兄的”利用ET中的FS写的一个简单的修剪内部线 “（利用et的fastsel)
snsj兄的“图形切割程序”（利用et的extrim)
...............................................................
受益颇多。
也想锻炼一下能否用vlisp，不用extrim编写相关程序。顺带问一下，为什么extrim在运行的时候会屏幕闪一下，有点像zoom的情况呢。
近日仔细阅读了John Uhden（John Uhden:写了不少用@开头的通用函数，http://www.cadlantic.com/）的trimlineinside函数之后，在其代码的基础上（原代码占80％以上比重）写下了如下的一段代码，用于修剪圆，文字，lwpolyline多边形。其原函数可以在其网站上下到，主要是考虑一个boundary和一个Line进行剪切处理，没有考虑线直接穿过boundary的情况，本代码主要加了这个部分，添加了文字的处理和多边形内部的erase清理的内容。在此多谢John Uhden。
其实我主要利用后两者来进行我们结构专业的梁柱交接处的修剪问题。命令为test.
刚刚发现这个程序的作用和eachy兄的这个程序有点类似，于是跟帖在这里了，eachy版主别怪：）
程序缺陷：对于凹多边形，直线的两段在凹多边形内部等几种情况会出现问题
[php]
;;--------------------------------------------------------------
;; trimlineinside.lsp (2003) john f. uhden, cadlantic/cadvantage
;; dedicated to mark <aikidoka> 01-18-03
;;--------------------------------------------------------------
;; an example of activex methods to trim a line inside a boundary
;;   without the use of the (command) function.
;; note that the intersectwith method requires two graphical objects,
;;   which limits the success of this function to objects being in the
;;   same plane.
;; arguments:
;;   boundary - either an entity name or vla-object of the trimming object
;;   line     - either an entity name or vla-object of the line to be trimmed
;; returns:
;;   t   - if either the line is already trimmed to the correct intersection,
;;         or a new intersection is applied
;;   nil - if there is any failure
;;
;; this is freeware, intended strictly for educational purposes only,
;  and is not necessarily error free or totally accurate.
;; you're on your own as to its usage and results.
;; feel free to correct and/or embellish it to your liking/needs.
(defun trimlineinside (boundary line / convert group sort onseg closest
                                layer p1 p2 ips on1 on2 ips2
                      )
  (vl-load-com)  ;; sub-function to convert an entity name to a vla-object
  ;; (if it's not already a vla-object),
  ;; or return nil if neither:
  (defun convert (e)
    (cond
      ((= (type e) 'vla-object)
        e
      )
      ((= (type e) 'ename)
        (vlax-ename->vla-object e)
      )
      (1 (prompt "\ninvalid object."))
    )
  )  ;; sub-function to group a list of items into a list of
  ;; multiple lists, each of length n, e.g.
  ;; '(a b c d e f g h i) -> '((a b c)(d e f)(g h i))
  (defun group (lst n / item new)
    (foreach element (reverse lst)
      (setq item (cons element item))
      (if (= (length item) n)
        (setq new (cons item new)
              item nil
        )
      )
    )
    new
  )  ;; sun-function to sort a list of 2d or 3d points in coordinate order,
  ;; first by the x coordinate and second by the y coordinate:
  (defun sort (pts)
    (setq pts (vl-sort pts (function (lambda (x y)
                                       (< (car x) (car y))
                                     )
                           )
              )
    )
   
    (setq pts (vl-sort pts (function (lambda (x y)
                                       (< (cadr x) (cadr y))
                                     )
                           )
              )
    )
  )  ;; sub-function to determine if a point 'p lies within the segment
  ;; defined by p1 and p2 (all credit due to david bethel):
  (defun onseg (p p1 p2)
    (equal (distance p1 p2) (+ (distance p p1) (distance p p2)) 1e-8)
  )  ;; sub-function to determine the closest 'pt to a given 'p
  ;; within a list of 'pts:
  (defun closest (p pts / found d dmin pt)
    (while pts
      (setq pt (car pts)
            d (distance p pt)
            pts (cdr pts)
      )
      (if (or
            (not dmin)
            (< d dmin)
          )
        (setq dmin d
              found pt
        )
      )
    )
    found
  )  ;; a stephan koster approach using a lengthy (and) to
  ;; "evaluate until failure":
  (and    ;; confirm the boundary is a vla-object
    (setq boundary (convert boundary))    ;; confirm the line is a vla-object
    (setq line (convert line))    ;; confirm the boundary is intersectable,
    ;; or prompt that it isn't:
    (or
      (vlax-method-applicable-p boundary 'intersectwith)
      (prompt "\nfirst object cannot be intersected.")
    )    ;; confirm that the line is a line,
    ;; or prompt that it isn't:
    (or
      (= (vlax-get line 'objectname) "AcDbLine")
      (prompt "\nsecond object is not a line.")
    )    ;; obtain the ungrouped list of intersections,
    ;; or prompt that there are none:
    (or
      (setq ips (vlax-invoke boundary 'intersectwith line
                             acextendotherentity
                )
      )
      (prompt "\nline does not intersect boundary.")
    )
    (or
      (setq ips1 (vlax-invoke boundary 'intersectwith line acextendnone))
    )    ;; confirm that the line's layer is unlocked,
    ;; or prompt if it is locked:
    (or
      (= (vla-get-lock (vlax-ename->vla-object (tblobjname "layer"
                                                           (setq layer
                                                                 (vlax-get line 'layer)
                                                           )
                                               )
                       )
         ) :vlax-false
      )
      (prompt (strcat "\nlayer " layer " is locked."))
    )    ;; group and sort the intersections into
    ;; consecutive x,y order:
    (setq ips (sort (group ips 3)))    ;; obtain the line's start point:
    (setq p1 (vlax-get line 'startpoint))    ;; obtain the line's end point:
    (setq p2 (vlax-get line 'endpoint))
    ;(setq ips2 nil)
    (setq ips2 (append
                 (list p1 p2)
                 (group ips1 3)
               )
    )
    ;(setq pub ips2)
    (setq ips2 (sort ips2))    ;; because of the (and), treat the following as a collection
    ;; of evaluations ending with t since either of the first
    ;; two evaluations may return nil:
   
    (progn
      (setq on1 (onseg p1 (car ips) (last ips)))
      (setq on2 (onseg p2 (car ips) (last ips)))
      t
    )    ;; if the (and) has made it this far, then check the
    ;; possible intersection conditions:
    (cond      ;; there is only one intersection and it equals
      ;; the line's start point,
      ;; so return t to indicate the line is okay:
      ((and
         (not (cdr ips))
         (equal (car ips) p1 1e-8)
       )
        t
      )      ;; there is only one intersection and it equals
      ;; the line's end point,
      ;; so return t to indicate the line is okay:
      ((and
         (not (cdr ips))
         (equal (car ips) p2 1e-8)
       )
        t
      )      ;; equivalent to (= (length ips) 1), but slightly faster,
      ;; determine that the line intersects the boundary only once,
      ;; meaning that there is no way of determining inside vs. outside:
      ((not (cdr ips))
        (prompt "\nline extension intersects boundary at only one point.")
      )      ;; neither end of the line is inside the boundary,
      ;; therefor both are outside:
      ((not (or
              on1
              on2
            )
       )        ;(prompt "\nboth ends of line are outside the boundary.")
        ;;;;;;;;;;;;;;;;this is add by qjchen;;;;;;;;;;;;;;;;;;;;
        (if (/= ips2 nil)
          (qj-trim line ips2)
        )        ;;;;;;;;;;;;;;;;end this is add by qjchen;;;;;;;;;;;;;;;;
      )      ;; if the line's start point is inside then modify it
      ;; to the intersection point closest to the end point:
      ((and
         on1
         (not on2)
       )
        (vlax-put line 'startpoint (closest p2 ips))
        t
      )      ;; if the line's end point is inside then modify it
      ;; to the intersection point closest to the start point:
      ((and
         on2
         (not on1)
       )
        (vlax-put line 'endpoint (closest p1 ips))
        t
      )      ;; ultimately, if both the line's start point and end point
      ;; lie on the intersection segment, then both points must be
      ;; on or inside the boundary, so there's nothing to trim:
      (1 (prompt "\nneither end of the line is outside boundary."))
    )
  )
)
;;;; the subrountine is write by qjchen to trim the line both end is
;;;;  out of the boundary
(defun qj-trim (l lst / makeline layer color ltype lscale lst2 x)
  (defun makeline (la co lt ls sp ep / a b i x lst lst1)
    (setq a (list lt co ls)
          b (list 6 62 48)
    )
    (setq i 0)
    (foreach x a
      (if (/= x nil)
        (setq lst (append
                    lst
                    (list (cons (nth i b) x))
                  )
        )
      )
      (setq i (1+ i))
    )
    (setq lst1 (append
                 (list (cons 0 "line") (cons 8 la) (cons 10 sp)
                       (cons 11 ep) ;***
                       (cons 39 0.0) (cons 210 (list 0.0 0.0 1.0))
                 )
                 lst
               )
    )
    (entmake lst1)
  )
  (setq l1 (vlax-vla-object->ename l))
  (setq l (entget l1))
  (setq layer (cdr (assoc 8 l)))
  (setq color (cdr (assoc 62 l)))
  (setq ltype (cdr (assoc 6 l)))
  (setq lscale (cdr (assoc 48 l)))
  (setq lst2 (group lst 2))
  (foreach x lst2
    (setq spp (car x)
          epp (cadr x)
    )
    (makeline layer color ltype lscale spp epp)
  )
  (entdel l1)
)
;;;; the subrountine is write by qjchen to get selection by circle
;;;; and lwpolyline
(defun objectpoint (obj / name ori i r w_pl_lst wlist)
  (setq name (cdr (assoc 0 obj)))
  (cond
    ((= name "CIRCLE")
      (setq ori (cdr (assoc 10 obj)))
      (setq r (cdr (assoc 40 obj)))
      (setq i 0)
      (repeat 30
        (setq wlist (append
                      wlist
                      (list (polar ori (* 2 pi (/ i 30.0)) r))
                    )
        )
        (setq i (1+ i))
      )
    )
    ((= name "LWPOLYLINE")
      (defun w_pl_lst (ent / pt_list)
        (foreach x ent
          (if (= (car x) 10)
            (setq pt_list (append
                            (list (cdr x))
                            pt_list
                          )
            )
          )
        )
        pt_list
      )
      (setq wlist (w_pl_lst obj))
    )
  )
  wlist
)

;;; The following code taken from Mr.Tony Hotchkiss at Cadalyst
(defun err (s)
  (if (= s "Function cancelled")
    (princ "\nregion clean - cancelled: ")
    (progn
      (princ "\nregion clean - Error: ")
      (princ s)
      (terpri)
    )                       ; _ end of progn
  )                       ; _ end of if
  (resetting)
  (princ "SYSTEM VARIABLES have been reset\n")
  (princ)
)
;;; err
;;; setting and resetting the system variables
(defun setv (systvar newval / x)
  (setq x (read (strcat systvar "1")))
  (set x (getvar systvar))
  (setvar systvar newval)
)
;;; setv
(defun setting ()
  (setq oerr *error*)
  (setq *error* err)
  (setv "BLIPMODE" 0)
  (setv "CMDECHO" 0)
  (setv "OSMODE" 0)
)
;;; setting
(defun rsetv (systvar)
  (setq x (read (strcat systvar "1")))
  (setvar systvar (eval x))
)
;;; rsetv
(defun resetting ()
  (rsetv "BLIPMODE")
  (rsetv "CMDECHO")
  (rsetv "OSMODE")
  (setq *error* oerr)
)
;;; -------------------------------------------------------

;; the main code of region clean, include circle and lwpolyline
;; write by qjchen   http://autolisper.googlepages.com
;; the code mainly use the
;; trimlineinside.lsp (2003) john f. uhden, cadlantic/cadvantage
;; dedicated to mark <aikidoka> 01-18-03
;; http://www.cadlantic.com/
;; great thanks to john f. uhden, I just write a little code to
;; realize my need                                             
;; but now the code is not total finished, when the line's two end
;; in a concave polygon, it will get wrong                       
(defun c:test (/ a b std-sslist bb xx txtbox x outline txtobj)
  (command "_undo" "_be")
  (setting)
  (defun std-sslist (ss / n lst)
    (if (eq 'pickset (type ss))
      (repeat (setq n (fix (sslength ss))) ; fixed
        (setq lst (cons (ssname ss (setq n (1- n))) lst))
      )
    )
  )
  (setq a (ssget '( (0 . "circle,lwpolyline,text"))))
  (setq a (std-sslist a))
  (foreach x a
    (setq txtobj nil)
    (setq pub x)
    (if (= (cdr (assoc 0 (entget x))) "TEXT")
      (progn
        (vla-getboundingbox (vlax-ename->vla-object pub) 'bp 'up)
        (command "rectang" (safearray-value bp) (safearray-value up))
        (setq txtobj (entlast))
        (setq x txtobj)
      )
    )
    (setq outline (objectpoint (entget x)))
    (setq b (ssget "_cp" outline '((0 . "LINE"))))
    (setq b (std-sslist b))
    (foreach y b
      (redraw y 3)
      (trimlineinside x Y)
    )
    (setq bb (ssget "_wp" outline '((0 . "LINE"))))
    (setq bb (std-sslist bb))
    (foreach xx bb
      (entdel xx)
    )
    (if txtobj
      (entdel txtobj)
    )
  )
  (resetting)
  (command "_undo" "_e")
)

[/php]

[iframe h=500 w=600]http://qjchen.googlepages.com/regiontrim.gif[/iframe]

gufengyin

是不是把修剪改为 wipeout  擦除好一点

TLHMQH

加载试用单行文字出现下面提示：
; 错误: no function definition: VLAX-ENAME->VLA-OBJECT
我的是2004，请问为什么？怎样改进？

TLHMQH

我试用的是前几个程序，当时第2页没打开，因此没试。
刚才试用了18楼snoopychen 的程序，可用。但在加载时，会打开“自定义”对话框，应在那修改？

522892119

不是很懂.学习中.多谢分享

clhclh

最初由 eachy 发布
[B]
高版本的CAD中 Dim 支持屏蔽，不需要修剪 [/B]

怎么屏蔽？我不会呀。告示我好吧？

happyboy75

两个都收下 研究研究

hzj526

两个程序各有千秋，收获很大，在此支持一下

sjs2003

我用的怎么显示出错？
选择对象:
; 错误: no function definition: VLAX-ENAME->VLA-OBJECT
这是怎么回事呢？

tm010111

snoopychen：您写的那个修剪的好像有一点点bug，有时候会翦不掉，反而会在中间多画出一段线？不知道为什么会这样，见附图，我可能没说清

eachy

重新改进了一点，不过完全在 Circle 或者 Text 内部的 短线 没有处理[pcode=lisp,true](defun c:tt ()
  (setvar "nomutt" 1)
  (setvar "cmdecho" 0)
  (vl-cmdf ".undo" "begin")
  (vl-catch-all-apply
    (function
      (lambda (/ ss1 ss l1 i ent midp el ssl ell pts)
        (while
          (progn
            (princ "\nSelect Circle,Text,Line,Lline<exit>: ")
            (setq ss1 (ssget "_C" '((0 . "Circle,Text,line,lwpolyline"))))
          )
           (setvar "osmode" (logior (getvar "osmode") 16384))
           (setq ss (ssget "P" '((0 . "text,circle"))))
           (setq l1 (sslength ss)
                 i  -1
           )
           (repeat l1
             (setq ent (ssname ss (setq i (1+ i))))
             (ssdel ent ss1)
             (vla-getboundingbox (vlax-ename->vla-object ent) 'bp 'up)
             (setq midp        (mapcar        '*
                                '(0.5 0.5 0.5)
                                (mapcar        '+
                                        (safearray-value bp)
                                        (safearray-value up)
                                )
                        )
             )
             (setq el (cons (list midp ent) el))
           )
           (setq ssl (sslength ss1)
                 i   -1
           )
           (repeat ssl
             (setq ent (ssname ss1 (setq i (1+ i))))
             (setq ell (mapcar '(lambda        (x / op pam)
                                  (setq
                                    op        (vlax-curve-getclosestpointto
                                          ent
                                          (car x)
                                        )
                                    pam        (vlax-curve-getparamatpoint
                                          ent
                                          op
                                        )
                                  )
                                  (list pam (car x) (cadr x))
                                )
                               el
                       )
             )
             (setq
               ell (vl-sort ell
                            '(lambda (e1 e2) (> (car e1) (car e2)))
                   )
             )
             (foreach x        ell
               (if
                 (and (setq pts        (vlax-invoke
                                  (vlax-ename->vla-object (last x))
                                  'Intersectwith
                                  (vlax-ename->vla-object ent)
                                  acExtendNone
                                )
                      )
                      (not (equal pts (vlax-curve-getstartpoint ent)))
                      (not (equal pts (vlax-curve-getendpoint ent)))
                 ) ;_2013.05.09
                  (command ".trim" (last x) "" (list ent (cadr x)) "")
               )
             )
           )
        )
      )
    )
  )
  (vl-cmdf ".undo" "end")
  (setvar "nomutt" 1)
  (princ)
)[/pcode]

/db_自贡黄明儒_

eachy 发表于 2013-5-10 00:53

                               
登录/注册后可看大图

重新改进了一点，不过完全在 Circle 或者 Text 内部的 短线 没有处理(defun c:tt ()
  (setvar "nomutt" 1 ...

刚才试了一下,这个运行不了

sicky111

要是能修剪BLOCK就更好了。