多义线线头或线尾加点（多段线接着画）

zjy2999 · 发表于 2017-10-12 09:04

;-----------多义线线头或线尾尾加点 pladp
;-----------支持polyine  LightweightPolyline
(defun c:pladp(/ pt obj pp fpa epa n newv pnt pltype vtxlst vtx vtxlst1)
(vl-load-com)
(if (setq CURVE (entsel "\n选择曲线:"))
   (progn
   (setq oob(entget (car CURVE)))
   (setq PLTYPE (cdr (assoc 0 (entget (car CURVE)))))
   (setq pt    (cadr CURVE))
   (setq  OBJ  (vlax-ename->vla-object (car CURVE)))
   (setq  PP (vlax-curve-getclosestpointto OBJ (trans Pt 1 0)))
   (setq  fpa (vlax-curve-getstartparam OBJ ))
   (setq  epa (fix (vlax-curve-getendparam  OBJ )))
   (setq  N (vlax-curve-getparamatpoint OBJ PP))
   (setq vtx (vla-get-Coordinates OBJ))
   (setq vtxlst (vlax-safearray->list (vlax-variant-value vtx)))
   (setq kk 0)
   (setq ptlst nil)
   (repeat (/ (length vtxlst) 3)
                     (setq ptlst (append ptlst (list (list (nth kk vtxlst) (nth (1+ kk) vtxlst)  (nth (+ 2 kk) vtxlst) ))))
                     (setq kk (+ kk 3))
   )
   ;判断线头线尾
   (if(> N ( / (+ fpa epa) 2))
   (setq pnt  (vlax-curve-getEndPoint  OBJ))
         (setq pnt  (vlax-curve-getStartPoint OBJ))
   )
   (command "_.undo" "_BE")
   (while  (setq p (getpoint pnt "\pick增加的顶点:"))



         (if  (= "LWPOLYLINE" PLTYPE)
         (progn
(setq p1 (list (car p) (cadr p)))
(setq NEWV (vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble '(0 . 1))
p1)
)
(if (> N ( / (+ fpa epa) 2))
(vla-addvertex OBJ (1+(fix (vlax-curve-getendparam  OBJ ))) NEWV)
(vla-addvertex OBJ 0 NEWV)
)
         )
         )

         (if  (= "POLYLINE" PLTYPE)
      (progn
      (setq p1 (list (car p) (cadr p) 0) )
      (setq NEWV (vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble '(0 . 2)) p1)
)
                        |;
         (if (> N ( / (+ fpa epa) 2))
(progn
;(setq ptlst1(list ptlst p1))
;(vlax-put OBJ 'coordinates ptlst1);设置坐标
(vla-AppendVertex  OBJ  NEWV)
)
(progn
      (setq vtxlst1 (cons  0.0 vtxlst))
      (setq vtxlst1 (cons  (cadr p) vtxlst1))
      (setq vtxlst1 (cons  (car p) vtxlst1))
      ;(setq len(length vtxlst1))
      ;(setq array (vlax-make-safearray vlax-vbdouble (cons 0  (- len 1))))
      ;(setq satarray1 (vlax-safearray-fill array vtxlst1))
     ;(setq ptzb(vlax-make-variant satarray1))
         ;(setq ptlst1(cons p1 ptlst ))
;(vla-put-coordinate obj 0 (vlax-make-variant
        ;(vlax-safearray-fill(vlax-make-safearray vlax-vbdouble '(0 . 2)) p1)))
(vlax-put OBJ 'coordinates vtxlst1);设置坐标
         (setq vtx (vla-get-Coordinates OBJ))
   (setq vtxlst (vlax-safearray->list (vlax-variant-value vtx)))
;(vla-AppendVertex  OBJ  NEWV)
      ;'(1 2 3)

                  )
   )
         )
      )
      (setq pnt p)

      )
   (command "_.undo" "_E")
))
)

lzj511 · 发表于 2017-10-19 22:49

13648893846 发表于 2017-10-12 20:36
大神如何换向呢

网络程序，感谢作者，多段线反向

(defun c:fan( / A B C D ENT LST LST1 TMP)
(SETQ EN (CAR (ENTSEL)))
  (setq ENT (entget EN))
  (setq tmp ent)
  (while (setq tmp (member (assoc 10 tmp) tmp))
(setq a (assoc 10 tmp)
   b (cons 40 (cdr (assoc 41 tmp)))
   c (cons 41 (cdr (assoc 40 tmp)))
   d (cons 42 (- (cdr (assoc 42 tmp))))
   LST (append (list b c d a) LST)
) ;_ 结束setq
(setq tmp (cddddr tmp))
  ) ;_ 结束while
  (repeat 3 (setq LST (append (cdr lst) (list (car lst)))))
  (setq lst1 (reverse (cdr (member (assoc 10 ent) (reverse ent)))))
  (entmod (append lst1 lst '((210 0 0 1))))
) ;_ 结束defun

13648893846 · 发表于 2017-10-21 20:00

lzj511 发表于 2017-10-19 22:49
网络程序，感谢作者，多段线反向

(defun c:fan( / A B C D ENT LST LST1 TMP)

多谢大神,不过我是问的楼主接着画的程序能否换向,

wzg356 · 发表于 2020-10-17 13:04

13648893846 发表于 2017-10-21 20:00
多谢大神,不过我是问的楼主接着画的程序能否换向,

点击的前半段后半段

13648893846 · 发表于 2017-10-12 20:36

大神如何换向呢

pxt2001 · 发表于 2017-10-14 23:10

希望楼主的程序，能支持ucs，能支持u回退。

fsafaffa · 发表于 2017-10-15 14:32

顶顶顶顶顶顶顶

pengfei2010 · 发表于 2017-10-16 08:55

回帖是一种美德！感谢楼主的无私分享谢谢

水仙的错 · 发表于 2017-10-19 16:56

为什么接着画就变成直线了？如果还是弧线顺过去就好了

004 · 发表于 2018-6-13 22:03

测绘，地形图编辑常用的功能！

sws · 发表于 2020-7-28 21:31

多谢大神多谢大神

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

[源码] 多义线线头或线尾加点（多段线接着画）

评分