求助伸缩齐线的程序？

soly2006 · 发表于 2013-9-30 00:12:04

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

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

×

怎么能处理如下图所示，白线（图层B）伸缩到红线（图层A）上，超出部分都为直线，
且可设定一个值，在这个值范围可伸缩到红线。
就是画线时可能调整后造成超出线和不足线，进行处理。
处理前：

处理后：

newer · 发表于 2013-9-30 00:16:34

是不是超出的部分，也按限定值处理呢？

soly2006 · 发表于 2013-9-30 00:18:37

newer 发表于 2013-9-30 00:16
是不是超出的部分，也按限定值处理呢？

在限定值内，把线头拉到（伸缩到）红线上就是。

newer · 发表于 2013-9-30 00:26:26

soly2006 发表于 2013-9-30 00:18
在限定值内，把线头拉到（伸缩到）红线上就是。

是LINE 和 POLYLINE 吧?

newer · 发表于 2013-9-30 00:29:07

你贴个测试的DWG上来吧。

soly2006 · 发表于 2013-9-30 00:49:48

newer 发表于 2013-9-30 00:29
你贴个测试的DWG上来吧。

测试文件

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:2121221.rar
下载次数:8 文件大小:5.89 KB
下载权限: 不限以上 [免费赚D豆]

eachy · 发表于 2013-9-30 17:47:45

soly2006 发表于 2013-9-30 00:49
测试文件

试试这个，运行环境xdapi

(defun c:tt (/ getnearestpt ext_trim ss sa sb d e pts ptl1 ptl2 sp ep)
(defun getnearestpt (e p pts fuzz / op ip d1 d2)
(foreach x pts
(if (vlax-curve-getparamatpoint e x)
(if ip
(if (< (abs (xdrx_curve_getdistatpoint e p x)) d1)
(setq ip x
d1 (abs (xdrx_curve_getdistatpoint e p x))
)
)
(if (< (abs (xdrx_curve_getdistatpoint e p x)) fuzz)
(setq ip x
d1 (abs (xdrx_curve_getdistatpoint e p x))
)
)
) ;_ on curve
(if op
(if (< (distance x p) d2)
(setq op x
d2 (distance x p)
)
)
(if (< (setq d2 (distance x p)) fuzz)
(setq op x
d2 (distance x p)
)
)
) ;_extend point
)
)
(if (and ip op)
(if (< (distance p op)
(xdrx_curve_getdistatpoint e p ip)
)
(list op)
(list ip)
)
(vl-remove nil (list ip op))
)
)
(defun ext_trim (e p pts fuzz mod / e1)
(if (vlax-curve-getparamatpoint e (car pts)) ;_ on curve
(if (setq e1 (xdrx_pickset->ents (xdrx_curve_break e (car pts)))) ;_返回新曲线集
(if mod ;_ Near endpoint
(entdel (car e1))
(if
(< (vlax-curve-getdistatparam e (vlax-curve-getendparam e))
fuzz
)
(progn
(xdrx_object_swapid e (car e1)) ;_Near Startpoint
(entdel (car e1))
)
(entdel (car e1)) ;_Near endpoint
)
)
)
(xdrx_entity_movestretchpoint
e
(mapcar '- (car pts) p)
(vl-position p (xdrx_entity_getstretchpoint e))
) ;_extend point
)
)
;;Main
(if (and (progn (prompt "\n选择边界...")
(setq sb (ssget '((0 . "*polyline"))))
)
(progn (prompt "\n选择裁剪延伸曲线....")
(setq sa (ssget))
) ;_ extend or trim
(setq d (getdist "\nFuzz dist: "))
)
(progn
(xdrx_setsstodb sa 0)
(while (setq e (xdrx_getentdata 0))
(if (or (not (vlax-curve-isclosed e))
(not (equal (vlax-curve-getstartpoint e)
(vlax-curve-getendpoint e)
1e-5
)
)
)
(progn
(setq sp (vlax-curve-getstartpoint e)
ep (vlax-curve-getendpoint e)
pts (xdrx_curve_getinters e sb 1)
)
(if (not (vl-member-if
'(lambda (x)
(equal ep x 1e-6)
)
pts
)
)
(setq ptl1 (getnearestpt e sp pts d))
) ;_ Near point of Startpoint
(if (not (vl-member-if
'(lambda (x)
(equal sp x 1e-6)
)
pts
)
)
(setq ptl2 (getnearestpt e ep pts d)) ;_ Near point of Endpoint
)
(if ptl2
(ext_trim e ep ptl2 d t)
)
(if ptl1
(ext_trim e sp ptl1 d nil)
)
)
)
)
)
)
(princ)
)

(defun c:tt (/ getnearestpt ext_trim ss sa sb d e pts ptl1 ptl2 sp ep) 
  (defun getnearestpt (e p pts fuzz / op ip d1 d2) 
    (foreach x pts 
      (if (vlax-curve-getparamatpoint e x) 
    (if ip 
      (if (< (abs (xdrx_curve_getdistatpoint e p x)) d1) 
        (setq ip x 
          d1 (abs (xdrx_curve_getdistatpoint e p x)) 
        ) 
      ) 
      (if (< (abs (xdrx_curve_getdistatpoint e p x)) fuzz) 
        (setq ip x 
          d1 (abs (xdrx_curve_getdistatpoint e p x)) 
        ) 
      ) 
    ) ;_ on curve 
    (if op 
      (if (< (distance x p) d2) 
        (setq op x 
          d2 (distance x p) 
        ) 
      ) 
      (if (< (setq d2 (distance x p)) fuzz) 
        (setq op x 
          d2 (distance x p) 
        ) 
      ) 
    ) ;_extend point 
      ) 
    ) 
    (if    (and ip op) 
      (if (< (distance p op) 
         (xdrx_curve_getdistatpoint e p ip) 
      ) 
    (list op) 
    (list ip) 
      ) 
      (vl-remove nil (list ip op)) 
    ) 
  ) 
  (defun ext_trim (e p pts fuzz mod / e1) 
    (if    (vlax-curve-getparamatpoint e (car pts)) ;_ on curve 
      (if (setq e1 (xdrx_pickset->ents (xdrx_curve_break e (car pts)))) ;_返回新曲线集 
    (if mod ;_ Near endpoint 
      (entdel (car e1)) 
      (if 
        (< (vlax-curve-getdistatparam e (vlax-curve-getendparam e)) 
           fuzz 
        ) 
         (progn 
           (xdrx_object_swapid e (car e1)) ;_Near Startpoint 
           (entdel (car e1)) 
         ) 
         (entdel (car e1)) ;_Near endpoint 
      ) 
    ) 
      ) 
      (xdrx_entity_movestretchpoint 
    e 
    (mapcar '- (car pts) p) 
    (vl-position p (xdrx_entity_getstretchpoint e)) 
      ) ;_extend point 
    ) 
  ) 
  ;;Main 
  (if (and (progn (prompt "\n选择边界...") 
          (setq sb (ssget '((0 . "*polyline")))) 
       ) 
       (progn (prompt "\n选择裁剪延伸曲线....") 
          (setq sa (ssget)) 
       ) ;_ extend or trim 
       (setq d (getdist "\nFuzz dist: ")) 
      ) 
    (progn 
      (xdrx_setsstodb sa 0) 
      (while (setq e (xdrx_getentdata 0)) 
    (if (or    (not (vlax-curve-isclosed e)) 
        (not (equal (vlax-curve-getstartpoint e) 
                (vlax-curve-getendpoint e) 
                1e-5 
             ) 
        ) 
        ) 
      (progn 
        (setq sp  (vlax-curve-getstartpoint e) 
          ep  (vlax-curve-getendpoint e) 
          pts (xdrx_curve_getinters e sb 1) 
        ) 
        (if    (not (vl-member-if 
               '(lambda    (x) 
              (equal ep x 1e-6) 
            ) 
               pts 
             ) 
        ) 
          (setq ptl1 (getnearestpt e sp pts d)) 
        ) ;_  Near point of Startpoint 
        (if    (not (vl-member-if 
               '(lambda    (x) 
              (equal sp x 1e-6) 
            ) 
               pts 
             ) 
        ) 
          (setq ptl2 (getnearestpt e ep pts d)) ;_ Near point of Endpoint 
        ) 
        (if    ptl2 
          (ext_trim e ep ptl2 d t) 
        ) 
        (if    ptl1 
          (ext_trim e sp ptl1 d nil) 
        ) 
      ) 
    ) 
      ) 
    ) 
  ) 
  (princ) 
)

Free-Lancer · 发表于 2013-9-30 18:29:38

有点复杂，还有简单的算法吗？

newer · 发表于 2013-9-30 20:04:51

eachy 发表于 2013-9-30 17:47
试试这个，运行环境xdapi

测试了下，没成，有些条件可能没考虑全

st788796 · 发表于 2013-9-30 20:48:59

newer 发表于 2013-9-30 20:04
测试了下，没成，有些条件可能没考虑全

换个 Lisp 版试试

游客，本帖隐藏的内容需要积分高于 30 才可浏览，您当前积分为 0

st788796 · 发表于 2013-10-1 01:40:52

newer 发表于 2013-9-30 20:04
测试了下，没成，有些条件可能没考虑全

break 后会产生新曲线，自断开点至原曲线尾端为新曲线
是删除原曲线还是删除新曲线由长度确定，不过应该保持原曲线，不然在用另一端的点处理时没有原实体会报错
用 lengthen 命令实体是不变的

21cn · 发表于 2013-10-1 06:03:02

eachy 发表于 2013-9-30 17:47
试试这个，运行环境xdapi

xdrx_curve_getdistatpoint给定两点时距离有正负，本例函数中要用abs
brkcurve对可以加个参数区分起点和终点

eachy · 发表于 2013-10-1 09:47:41

newer 发表于 2013-9-30 20:04
测试了下，没成，有些条件可能没考虑全

代码已修改,这次应该可以了
原来想用xdrx_points_sortoncurve 后来发现这个函数有限制，抽空把测试另贴

soly2006 · 发表于 2013-10-8 15:46:35

本帖最后由 soly2006 于 2013-10-8 15:59 编辑

还是不行啊,"错误: 参数值错误: AcDbCurve 2126518880"

eachy · 发表于 2013-10-8 18:04:07

soly2006 发表于 2013-10-8 15:46
还是不行啊,"错误: 参数值错误: AcDbCurve 2126518880"

7楼代码

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

[求助] 求助伸缩齐线的程序？

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

相关帖子

点评

点评

点评

点评

点评

评分

点评

点评