pedit 操作polyline

wzg356

"Lwpolyline"加删点继续画等程序比较多了，本论坛随便搜

关于polyline加删点、继续画等功能，难度高，本人纯lisp写还无法逾越

改用(command "pedit".......)配合,成了，还以为polyline、Lwpolyline都可以通用

突然发现

(command "pedit"..编辑顶点......拉直....)及（command "pedit".编辑顶点...插入....)后

"AcDb3dpolyline"的线（我简单用3dpoly画的）没事

"AcDb2dpolyline" 的线（cass画的宗地图）图元名、句柄没变，(0 . "polyline")却变成了(0 . "Lwpolyline")


polyline变成了Lwpolyline有点严重了
没心肠继续了

程序在下面已完成的可以用，只是上面的问题没解决
有高手出点意见为谢！！！！！

----------------------
说明一下，程序中获取多线段的子段或顶点索引已改用几何法
结果与(vlax-curve-getparamatpoint obj pp)法类似，二维操作更严密
个别没使用的函数也放在里面，有用到的拿去参考
20201012已更新

wzg356

;多段线顶点数量
;;示例 (GetCurveptNum (car (entsel)))
(defun GetCurveptNum (obj)
  (if (vlax-curve-isClosed obj)
    (fix (vlax-curve-getendParam obj))
    (1+ (fix (vlax-curve-getendParam obj)))
  )
)
;[功能] pline,lwpline点坐标表  By 无痕
;;选直线时坐标会很多很多
;真假封闭多线段坐标数量不同
;;示例(GetCurvepts (car (entsel))),返回二(三)维点坐标
(defun GetCurvepts (e / i v lst)
        (setq i -1)
        (while(setq v(vlax-curve-getpointatparam e (setq i (1+ i))))
                (setq lst (cons (list (car v)(cadr v)) lst))
                ;(setq lst (cons v lst))
        )
        (reverse lst)
)
;判断点在多线段上位置
;返回nil或点在线上位置;
;类似(vlax-curve-getparamatpoint obj pp)的结果，更准确
;(isptonpline (GetCurvepts(car (setq en(entsel))))(cadr en) 0.05)
(defun isptonpline (pts pt fz / isptonpline loop nn l)
        (defun IsPtOnLine (pt l1 l2 fz)
                (equal (+ (distance l1 pt) (distance l2 pt))
                         (distance l1 l2) fz
                )
        )
        (setq loop nil nn 0)
        (while(and (not loop)(> (length pts)1))
                (if        (setq loop(IsPtOnLine pt (car pts)(cadr pts) fz))
                    (progn                            (setq l (distance (car pts)(cadr pts)))
                            (if (and(< (distance pt (car pts)) l)(< (distance pt (cadr pts)) l))
                                        (setq loop(+ nn(/(distance pt (car pts))l)))
                                        (setq loop nn)
                            );防止0长度线出错
                    )      
                )                                
                (setq pts (cdr pts))(setq nn (1+ nn))
        )
        loop
)
;根据线上位置获得pline,lwpline顶点索引（起始端为0）
;;示例(Pickpl2numPt (car(setq en(entsel))) (cadr en))
(defun Pickpl2numPt (en p / num )
        (setq num(GetCurveptNum en))        
        (setq n(fix (+ 0.5(isptonpline (GetCurvepts en) p 0.05))))
        (if (= n num)0 n)
)
;根据线上位置获得pline,lwpline子段索引（起始段为0）
;;示例(Pickpl2numl (car(setq en(entsel))) (cadr en))
(defun Pickpl2numl (en p / )
        (fix (isptonpline (GetCurvepts en) p 0.05))
)

;[功能] pline,lwpline假闭合
;;示例(CurveLikeClosed (car (entsel)) 0.01)
(defun LikeClosed (e fz)
  (and (not(vlax-curve-isClosed e))
           (equal (vlax-curve-getStartPoint e)
                      (vlax-curve-getEndPoint e)
                      fz
      )
  )
)
;[功能] pline,lwpline删终点
;;示例(DelCurveEndpt1 (car (entsel)))
(defun DelCurveEndpt1 (en / num ns)
        (setq num(GetCurveptNum en))
        (if(> (setq num(GetCurveptNum en))2);顶点数
                (progn
                        (repeat  (- num 2)(setq ns(cons "n" ns)))
                        (eval(append
                                    (list 'command "_pedit" 'en "e")
                                    (append ns(list "b" "g" "x" ""))
                                )
                        );打断
                        (entdel(entlast))
                )
        )
);打断法---优点是真删
(defun DelCurveEndpt (en / num pt ns)
        (if(> (setq num(GetCurveptNum en))2);顶点数
                (progn
                        (setq pt(vlax-curve-getPointAtParam en (- num 2)));前一点坐标
                        (repeat  (- num 3)(setq ns(cons "n" ns)))
                        (eval(append(list 'command "_pedit" 'en "e")
                                                (append ns(list "s" "n" "n""g" "x" ""))
                        ));拉直-删除前一点
                        (setq ns(cons "n" ns))
                        (eval(append(list 'command "_pedit" 'en "e")
                                                (append ns(list "m" "non" 'pt "x" ""))
                        ));移动端点到前一点
                )               
        )
);移动法---缺点是假删

;[功能] pline,lwpline删起点
;;示例(DelCurveStartpt (car (entsel)))
;移动法，打断法不可取
(defun DelCurveStartpt (en / num pt)
        (if(> (setq num(GetCurveptNum en))2);顶点数
                (progn
                        (setq pt(vlax-curve-getPointAtParam en 1)); 第二点坐标
                        (eval(append(list 'command "_pedit" 'en "e")
                                                (list "s" "n" "n""g" "x" "")
                        ));拉直-删除第二点
                        (eval(append(list 'command "_pedit" 'en "e")
                                                (list "m" "non" 'pt "x" "")
                        ));移动端点到前一点
                )               
        )
)-----这是假删起点，优点是保护了主图元

;[功能] pline,lwpline 按顶点索引删点
;index起点为0
;;示例(DelCurvept (car (entsel)) 1)
(defun DelCurvept (en index / num pt ns)
        (if(> (setq num(GetCurveptNum en))2);顶点数
                (cond
                        ((and (> index 0) (< index (- num 1)))
                            (repeat (1- index)(setq ns(cons "n" ns)))
                            (eval(append(list 'command "_pedit" 'en "e")
                                                (append ns(list "s" "n" "n""g" "x" ""))
                                ));拉直-删除                                
                        )
                        ((= index 0)(DelCurveStartpt en))
                        ((= index (- num 1))(DelCurveEndpt en))
                        (t nil)
                )
        );
)
;[功能] pline,lwpline 按子段索引加点
;index起点为0
(defun AddCurvept (en index pt / ns)
        (repeat  index(setq ns(cons "n" ns)))
        (eval(append(list 'command "_pedit" 'en "e")
                                (append ns(list "i" 'pt "x" ""))
        ))
)
;[功能] pline,lwpline 继续画1点
;tt为nil则从起点开始
(defun ContinuePL (en pt tt / num pt0)
        (setq num (GetCurveptNum en));顶点数
        (if tt(AddCurvept en (1- num) pt);终端加点
                (progn
                        (setq pt0(vlax-curve-getPointAtParam en 0));起点坐标
                        (eval(append(list 'command "_pedit" 'en "e")
                                                (list "m" "non" 'pt "x" "")
                        ));移动起点
                        (AddCurvept en 0 pt0);第1子段加点                        
                )
        )        
)
;程序1
;pline,lwpline 删顶点
(defun c:plsd ( / en ent)
(setvar "cmdecho" 0)
(initget "  ")
(setq en (entsel "\n点击要删除的多线段顶点..."))
(cond
        ((= en "")nil)
        ((and (setq ent (car en))
                        (wcmatch(cdr(assoc 0(entget ent)))"*POLYLINE")
                )
                (DelCurvept ent (Pickpl2numPt ent (cadr en)))
                 (c:plsd)
        )
        (t (c:plsd))        
)
(setvar "cmdecho" 1)
(princ)
)
;程序2
;pline,lwpline 加点
(defun c:pljd ( / en ent)
(setvar "cmdecho" 0)
(initget "  ")
(setq en (entsel "\n点击多线段子段..."))
(cond
        ((= en "")nil)
        (        (and (setq ent (car en))
                        (wcmatch(cdr(assoc 0(entget ent)))"*POLYLINE")
                )
                (princ "\n指定加点位置")               
                (AddCurvept ent (Pickpl2numl ent (cadr en)) (getpoint))
                 (c:pljd)
        )
        (t (c:pljd))        
)
(setvar "cmdecho" 1)
(princ)
)

;程序3
;pline,lwpline继续画
(defun c:pljx ( / en obj seflag cflag endpt okflag pt)
(initget "  ")
(setq en (entsel "\n选择多线段..."))
(cond
        ((= en "")nil)
        ((and (setq en (car en))
                        (wcmatch(cdr(assoc 0(entget en)))"*POLYLINE")
                        (setq obj (vlax-ename->vla-object en))                                
                )
                (setq seflag t);默认从末端开始画
                (setq cflag (if(vlax-curve-isClosed obj)1 0));闭合情况
                (setq obj (vlax-ename->vla-object en))
                (and (= cflag 1) (vla-put-closed obj 0));闭合则打开
                (setq endpt (trans(vlax-curve-getEndPoint OBJ)0 1));终点
                (setq okflag nil);结束标志
                (setvar "cmdecho" 0)               
                (while(and(not okflag)
                              (car (list t (initget "S E C  " )));永远返回t
                  (setq pt (getpoint endpt "\n指定下一点[S起点开始/E终点开始/C闭合]:"))
            )            
            (cond
                    ((= (type pt) 'list)
                            (ContinuePL en pt seflag)
                            (if seflag
                                    (setq endpt (trans(vlax-curve-getEndPoint OBJ)0 1));终点
                                    (setq endpt (trans(vlax-curve-getStartPoint OBJ)0 1));起点
                            )
                    )
                    ((and (= (type pt) 'str)(= pt "S"))
                            (setq seflag nil)
                            (setq endpt (trans(vlax-curve-getStartPoint OBJ)0 1))
                    )
                    ((and (= (type pt) 'str)(= pt "E"))
                            (setq seflag t)                            (setq endpt (trans(vlax-curve-getEndPoint OBJ)0 1));终点
                    )
                    ((and (= (type pt) 'str)(= pt "C"));闭合就结束
                            (setq cflag 1)
                            (setq okflag t)
                    )
                    (t (setq okflag t))
            )            
        )
        (vla-put-closed obj cflag);恢复闭合状态
        (setvar "cmdecho" 1)
        )        
)
(princ)
)

cghdy

谢谢分享，非常好用

cghdy

提两个使用上的问题：1、pljx只能从结束点开始加线，最好能修改成选取段最近端点开始加线，实用性将大大增强。2、pljd和plsd在多次使用后无法识别清楚拾取段（点），反而在别的位置加点了。

wzg356

cghdy 发表于 2020-10-12 10:05
提两个使用上的问题：1、pljx只能从结束点开始加线，最好能修改成选取段最近端点开始加线，实用性将大大增 ...

1继续画一般从起点或终点开始就行了
中间加点也是连续循环的，可以在不同子段，不同图元之间连续进行，不必改了
2 子段端点识别问题，改为纯几何法算
已更新

cghdy

wzg356 发表于 2020-10-12 11:33
1继续画一般从起点或终点开始就行了
中间加点也是连续循环的，可以在不同子段，不同图元之间连续进行， ...

非常感谢，但是对于第一点我还是保留我的意见

cghdy

wzg356 发表于 2020-10-12 11:33
1继续画一般从起点或终点开始就行了
中间加点也是连续循环的，可以在不同子段，不同图元之间连续进行， ...

你好，更新后程序无法正常使用，下面两个函数会出错。
;根据线上位置获得pline,lwpline顶点索引（起始端为0）
;;示例(Pickpl2numPt (car(setq en(entsel))) (cadr en))
(defun Pickpl2numPt (en p / num )
        (setq num(GetCurveptNum en))
        (setq n(fix (+ 0.5 (isptonpline (GetCurvepts en) p 0.05))))
        (if (= n num)0 n)
)
;根据线上位置获得pline,lwpline子段索引（起始段为0）
;;示例(Pickpl2numl (car(setq en(entsel))) (cadr en))
(defun Pickpl2numl (en p / )
        (fix (isptonpline (GetCurvepts en) p 0.05))
)