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

eachy · 发表于 2006-5-26 11:49:57

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

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

×

(defun ybl-midp (p1 p2)
(mapcar '(lambda (x) (/ x 2.)) (mapcar '+ p1 p2))
)
(defun c:tt (/ e ss i ssl ent midp op pam el BP ELL ENT L1 OP PAM SS1 UP
X)
(if (and (progn
(princ "\nSelect Line,Pline ....")
t
)
(setq ss1 (ssget '((0 . "line,lwpolyline,polyline"))))
(progn
(princ "\nSelect Circle text ....")
t
)
(setq ss (ssget '((0 . "circle,text"))))
)
(progn
(setq l1 (sslength ss)
i -1
)
(repeat l1
(setq ent (ssname ss (setq i (1+ i))))
(vla-getboundingbox (vlax-ename->vla-object ent) 'bp 'up)
(setq midp (ybl-midp (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
(command ".trim" (last x) "" (list ent (cadr x)) "")
)
)
)
)
(princ)
)

(defun ybl-midp        (p1 p2) 
  (mapcar '(lambda (x) (/ x 2.)) (mapcar '+ p1 p2)) 
) 
(defun c:tt (/ e ss i ssl ent midp op pam el BP        ELL ENT        L1 OP PAM SS1 UP 
             X) 
  (if (and (progn 
             (princ "\nSelect Line,Pline ....") 
             t 
           ) 
           (setq ss1 (ssget '((0 . "line,lwpolyline,polyline")))) 
           (progn 
             (princ "\nSelect Circle text ....") 
             t 
           ) 
           (setq ss (ssget '((0 . "circle,text")))) 
      ) 
    (progn 
      (setq l1 (sslength ss) 
            i  -1 
      ) 
      (repeat l1 
        (setq ent (ssname ss (setq i (1+ i)))) 
        (vla-getboundingbox (vlax-ename->vla-object ent) 'bp 'up) 
        (setq midp (ybl-midp (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 
          (command ".trim" (last x) "" (list ent (cadr x)) "") 
        ) 
      ) 
    ) 
  ) 
  (princ) 
)

snoopychen · 发表于 2006-5-26 16:08:02

程序很好用，好好的学习了eachy版主的程序，学到了不少东西，包括文字原来现在可以trim了，现在真是落伍了，还有mapcar和lambda的用法。

报告一下bug，如下图所示，对于45度线（其实到89度都有可能）出现的情况：
部分比较靠近角部的直线，trim完之后有些问题，如红线所示

仔细学习了版主的程序，应该是以文字中心作为midp，找线上最近点op，
当在比较角部的地方，选中的最近点是在文字外部的，此时就会导致部分线是截取掉一半而非trim
这些线假如手工用trim且选取文字内部部分的时候是可以trim掉的

所以我觉得要是可以用文本box和实体两个交点中的中点来做op点会更安全一点，不过可能编程会比较麻烦。

:p，鸡蛋里面挑骨头，eachy版主别气：）

eachy · 发表于 2006-5-26 16:16:35

运行前去除 OSMODE 或者在程序中增加

snoopychen · 发表于 2006-5-26 16:42:04

好像不是osmode的问题，已经设置为0了

raobinhsh · 发表于 2006-5-26 16:43:02

对于图块中的怎么办？会不会把圆外的线剪掉？

eachy · 发表于 2006-5-26 20:57:44

(defun c:tt (/ ss ssl i obj p1 p2 s1 sl m l ipts pts p)
(princ "\nselect circle text ....")
(if (setq ss (ssget '((0 . "circle,text"))))
(progn
(if (< (getvar "osmode") 13684)
(setvar "osmode" (+ (getvar "osmode") 13684))
)
(command ".undo" "be")
(setq ssl (sslength ss)
i -1
)
(repeat ssl
(setq e (ssname ss (setq i (1+ i)))
obj (vlax-ename->vla-object e)
)
(vla-getboundingbox obj 'bp 'up)
(setq p1 (safearray-value bp)
p2 (safearray-value up)
)
(if (setq s1 (ssget "_c" p1 p2 '((0 . "line,lwpolyline"))))
(progn
(setq sl (sslength s1)
m -1
)
(repeat sl
(setq l (ssname s1 (setq m (1+ m)))
ipts (safearray-value
(variant-value
(vla-intersectwith
obj
(vlax-ename->vla-object l)
0
)
)
)
)
(while ipts
(setq pts (cons (list (car ipts) (cadr ipts) (caddr ipts))
pts
)
ipts (cdddr ipts)
)
)
(setq p (mapcar '(lambda (x) (/ x (length pts)))
(apply 'mapcar (cons '+ pts))
)
pts nil
)
(command ".trim"
e
""
(list l p)
""
)
)
)
)
)
(command ".undo" "end")
)
)
(princ)
)

(defun c:tt (/ ss ssl i obj p1 p2 s1 sl m l ipts pts p) 
  (princ "\nselect circle text ....") 
  (if (setq ss (ssget '((0 . "circle,text")))) 
    (progn 
      (if (< (getvar "osmode") 13684) 
        (setvar "osmode" (+ (getvar "osmode") 13684)) 
      ) 
      (command ".undo" "be") 
      (setq ssl        (sslength ss) 
            i        -1 
      ) 
      (repeat ssl 
        (setq e          (ssname ss (setq i (1+ i))) 
              obj (vlax-ename->vla-object e) 
        ) 
        (vla-getboundingbox obj 'bp 'up) 
        (setq p1 (safearray-value bp) 
              p2 (safearray-value up) 
        ) 
        (if (setq s1 (ssget "_c" p1 p2 '((0 . "line,lwpolyline")))) 
          (progn 
            (setq sl (sslength s1) 
                  m  -1 
            ) 
            (repeat sl 
              (setq l         (ssname s1 (setq m (1+ m))) 
                    ipts (safearray-value 
                           (variant-value 
                             (vla-intersectwith 
                               obj 
                               (vlax-ename->vla-object l) 
                               0 
                             ) 
                           ) 
                         ) 
              ) 
              (while ipts 
                (setq pts  (cons (list (car ipts) (cadr ipts) (caddr ipts)) 
                                 pts 
                           ) 
                      ipts (cdddr ipts) 
                ) 
              ) 
              (setq p        (mapcar        '(lambda (x) (/ x (length pts))) 
                                (apply 'mapcar (cons '+ pts)) 
                        ) 
                    pts        nil 
              ) 
              (command ".trim" 
                       e 
                       "" 
                       (list l p) 
                       "" 
              ) 
            ) 
          ) 
        ) 
      ) 
      (command ".undo" "end") 
    ) 
  ) 
  (princ) 
)

snoopychen · 发表于 2006-5-27 08:25:44

测试汇报：现在不会有45度的修剪问题。
不过好像不够原来的稳定
不知道用了ssget .c函数之后，是不是对图面有较高的要求呢，似乎有些图形zoom的大了或者小了
结果会不一样，有时候会出现参数太少的提示，不大弄的懂什么时候会出现
比如下面这个图的圆就经常出错，文字在不同zoom的情况下，有时候会出现中断，提示参数太少
CAD2004 osmode＝0
不知道是不是我这个cad不大行的缘故

由于对区域修剪及打断很有兴趣，希望借此再请教两个问题
1）假如想通过一点选择物体，在lisp中是不是只能构建一个ssget c的小窗口，这种构建法在图面很密集的时候似乎会出现问题，有没有更好的方法，对vla－selectatpoint的应用总觉得很奇怪，每次选取的结果似乎都不一样，能否请告知是怎么用的
2）第二个，比如我现在圆里面有很多短线，没有和圆相交，想删除它们，不知道怎么构建圆选择区，是否一定得用多边形来逼近

eachy · 发表于 2006-5-27 09:01:47

这样改改再试

(defun c:tt (/ ss ssl i obj p1 p2 s1 sl m l ipts pts p)
(princ "\nselect circle text ....")
(if (setq ss (ssget '((0 . "circle,text"))))
(progn
(if (< (getvar "osmode") 13684)
(setvar "osmode" (+ (getvar "osmode") 13684))
)
(command ".undo" "be")
(setq ssl (sslength ss)
i -1
)
(repeat ssl
(setq e (ssname ss (setq i (1+ i)))
obj (vlax-ename->vla-object e)
)
(vla-getboundingbox obj 'bp 'up)
(setq p1 (safearray-value bp)
p2 (safearray-value up)
)
(if (setq s1 (ssget "_c" p1 p2 '((0 . "line,lwpolyline"))))
(progn
(setq sl (sslength s1)
m -1
)
(command ".trim" (list e p1) "")
(repeat sl
(setq l (ssname s1 (setq m (1+ m)))
ipts (safearray-value
(variant-value
(vla-intersectwith
obj
(vlax-ename->vla-object l)
0
)
)
)
)
(if ipts
(progn (while ipts
(setq pts (cons
(list (car ipts) (cadr ipts) (caddr ipts))
pts
)
ipts (cdddr ipts)
)
)
(setq p (mapcar '(lambda (x) (/ x (length pts)))
(apply 'mapcar (cons '+ pts))
)
pts nil
)
(command (list l p))
)
)
)
(command "")
)
)
)
(command ".undo" "end")
)
)
(princ)
)

(defun c:tt (/ ss ssl i obj p1 p2 s1 sl m l ipts pts p) 
  (princ "\nselect circle text ....") 
  (if (setq ss (ssget '((0 . "circle,text")))) 
    (progn 
      (if (< (getvar "osmode") 13684) 
        (setvar "osmode" (+ (getvar "osmode") 13684)) 
      ) 
      (command ".undo" "be") 
      (setq ssl        (sslength ss) 
            i        -1 
      ) 
      (repeat ssl 
        (setq e          (ssname ss (setq i (1+ i))) 
              obj (vlax-ename->vla-object e) 
        ) 
        (vla-getboundingbox obj 'bp 'up) 
        (setq p1 (safearray-value bp) 
              p2 (safearray-value up) 
        ) 
        (if (setq s1 (ssget "_c" p1 p2 '((0 . "line,lwpolyline")))) 
          (progn 
            (setq sl (sslength s1) 
                  m  -1 
            ) 
            (command ".trim" (list e p1) "") 
            (repeat sl 
              (setq l         (ssname s1 (setq m (1+ m))) 
                    ipts (safearray-value 
                           (variant-value 
                             (vla-intersectwith 
                               obj 
                               (vlax-ename->vla-object l) 
                               0 
                             ) 
                           ) 
                         ) 
              ) 
              (if ipts 
                (progn (while ipts 
                         (setq pts  (cons 
                                      (list (car ipts) (cadr ipts) (caddr ipts)) 
                                      pts 
                                    ) 
                               ipts (cdddr ipts) 
                         ) 
                       ) 
                       (setq p         (mapcar '(lambda (x) (/ x (length pts))) 
                                         (apply 'mapcar (cons '+ pts)) 
                                 ) 
                             pts nil 
                       ) 
                       (command (list l p)) 
                ) 
              ) 
            ) 
            (command "") 
          ) 
        ) 
      ) 
      (command ".undo" "end") 
    ) 
  ) 
  (princ) 
)

第二个问题可以用ET函数 ACET-GEOM-OBJECT-POINT-LIST 构造点然后用 wp 选择

snoopychen · 发表于 2006-5-27 10:06:25

这次可以了，效果很好，谢谢：）
让我再仔细读读函数，现在还有点没想通第一种方法和第二种方法的根本区别。
第二个函数和第三个函数的trim放置位置居然如此不同。
ACET-GEOM-OBJECT-POINT-LIST系列函数也要好好学学

aeo · 发表于 2006-5-27 16:47:33

如果研究trim是怎么写出来的,
对于curve应该是求交点,而不是curve的应该是求出它的外框交点(text要适当往外偏移)
然后就应该是交点打断了.

雨箭风刀 · 发表于 2006-5-28 03:26:07

还要加上对ucs的处理

hao3ren · 发表于 2006-6-8 17:20:12

eachy 斑竹可不可以增加修剪穿过尺寸标注文字的线

eachy · 发表于 2006-6-8 17:40:19

最初由 hao3ren 发布
[B]eachy 斑竹可不可以增加修剪穿过尺寸标注文字的线 [/B]

高版本的CAD中 Dim 支持屏蔽，不需要修剪

liqilin7288 · 发表于 2006-6-10 10:47:09

谢谢楼主，也谢谢snoopychen不厌其烦地测试

zhouri · 发表于 2006-6-12 22:28:52

请教为何在vlisp函数集中没有诸如vla-intersectwith的函数,这些函数的用法在哪里可以查到,谢谢.

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

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

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

相关帖子