大家写一个给多段线增加顶点的函数

XDSoft

函数要求在给定的顶点索引之后增加一个顶点，包括弧线段：

功    能：在指定索引位置处增加一个顶点 调用格式：(Ent:Polyline-AddVertexAt  <LWPOLYLINE实体名> <index索引值> <点> [bulge值] [起始宽度][结束宽度]) 返 回 值：成功T, 否 NIL 说    明： 1、参数 [bulge值] [起始宽度][结束宽度]都为可选项，默认值都为0 ，后面的可选项若要设置必须前面的可选项也设置，但该可选项后面的若要默认值，可以省略。           [bulge值]--实数，若加弧段给BULGE值。0退化为直线           [起始宽度]，[结束宽度]--实数值或者整数值。 2、程序要求对参数值判断类型，只对合法的参数类型执行。

Free-Lancer

Autolisp 子函数不支持可选参数，当然传递List另说

sachindkini

DEAR SIR,

I THING IS USE FULL
[pcode=lisp,true](defun c:test(/ fl flnm)
  (defun listevertex (ent)
    (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= 10 (car x)))) (entget ent)))
  )
  (setq flnm "Test.txt")
  (if (setq ent (entsel "\nSelect pline."))
    (progn
      (setq fl (open flnm "w"))
      (princ (listevertex (car ent)) fl)
       (close fl)
    )
  )
  (princ)
)[/pcode]

XDSoft

Free-Lancer 发表于 2013-5-4 15:01

                               
登录/注册后可看大图

Autolisp 子函数不支持可选参数，当然传递List另说

那就传递LIST了， 函数调用用 APPLY ，试试写写。

Free-Lancer

[pcode=lisp,true](defun LwAddVertex (lw Index pt bugle sw ew)
  (setq lw (vlax-ename->vla-object lw)
        pt (trans pt 1 0)
        pt (list (car pt) (cadr pt)))
  (vlax-invoke lw 'addvertex index pt)
  (vl-catch-all-apply
    'vla-setbulge
    (list lw index bugle)
  )
  (vl-catch-all-apply
    'vla-setwidth
    (list lw index sw ew)
  )
)[/pcode]

Free-Lancer

lst 参数可以变长度了
[pcode=lisp,true](defun LwAddVertex (lst)
  (not (vl-catch-all-error-p
  (vl-catch-all-apply
    (function (lambda ()
         ;|(setq lw    (car lw)
        index (cadr lst)
        pt    (nth 2 lst)
        bugle (nth 3 lst)
        sw    (nth 4 lst)
        ew    (last lst)
         )|;
         (mapcar 'set '(lw index pt bugle sw ew) lst)
         (setq lw (vlax-ename->vla-object lw)
        pt (trans pt 1 0)
        pt (list (car pt) (cadr pt))
         )
         (vlax-invoke lw 'addvertex index pt)
         (vl-catch-all-apply
    'vla-setbulge
    (list lw index bugle)
         )
         (vl-catch-all-apply
    'vla-setwidth
    (list lw index sw ew)
         )
       )
    )
  )
       )
  )
)[/pcode]

liuyun242

Free-Lancer 发表于 2013-5-4 16:30

                               
登录/注册后可看大图

lst 参数可以变长度了
(defun LwAddVertex (lst)
  (not (vl-catch-all-error-p

这个不错，可以进入库函数

kwok

要是在多段线有弧的地方加点弧不变，只是加了点，那就完美了

Free-Lancer

kwok 发表于 2013-5-4 18:23

                               
登录/注册后可看大图

要是在多段线有弧的地方加点弧不变，只是加了点，那就完美了

增加顶点有两种情况，一是直接在线上增加，二是在线外增加，在线上增加用 GetClosestPointto 处理到 Pline 上，保持圆弧都可以做到
还有一种情况没有处理，如果点在起点或者终点以外，上面的函数是有Bug的，这时候先要将起点或者终点的 Coordinate 改变到新增点，然后将原起点或终点作为 AddVertex
在上面的函数中还有一个现象，AddVertex后Pline的 Index 没有改变，可能Update后才是新的 Index

sachindkini

[pcode=lisp,true];; CPL Calling Function

(defun c:cpl (/ ss n)
  (vl-load-com)
  (princ
    "\nSelect plines or <All>: "
  )
  (or (setq ss (ssget '((0 . "LWPOLYLINE"))))
      (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
  )
  (if ss
    (progn
      (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
      (setq n -1)
      (while (setq pl (ssname ss (setq n (1+ n))))
        (CleanPline pl nil)
      )
      (princ (strcat "\n\t" (itoa n) " treated pline(s)."))
      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
    )
    (princ "\nNone pline selected.")
  )
  (princ)
)

;; PPL Calling Function

(defun c:ppl (/ ss n)
  (vl-load-com)
  (princ
    "\nSelect plines or <All>: "
  )
  (or (setq ss (ssget '((0 . "LWPOLYLINE"))))
      (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
  )
  (if ss
    (progn
      (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
      (setq n -1)
      (while (setq pl (ssname ss (setq n (1+ n))))
        (CleanPline pl T)
      )
      (princ (strcat "\n\t" (itoa n) " treated pline(s)."))
      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
    )
    (princ "\nNone pline selected.")
  )
  (princ)
)

;; CleanPline (gile) 2007/11/13
;; Deletes superfluous vertex (aligned or overlapped) in a lwpolyline
;; Keeps arcs and widthes.
;;
;; Arguments
;; pl : the polyline to be treated (ename)
;; tt : T ou nil
;;    - T deletes all vertex aligned or on the same arc
;;    - nil keeps vertex which come back on the pline traject

(defun CleanPline (pl            tt             /              regular-width        elst
                   closed   old-p    old-b    old-sw   old-ew        new-p
                   new-b    new-sw   new-ew   b1       b2
                  )

  (defun regular-width (p1 p2 p3 ws1 we1 ws2 we2 / delta norm)
    (setq delta        (- we2 ws1)
    )
    (and (= we1 ws2)
         (equal        (/ (- (vlax-curve-getDistAtPoint pl (trans p2 pl 0))
                      (vlax-curve-getDistAtPoint pl (trans p1 pl 0))
                   )
                   (- (vlax-curve-getDistAtPoint pl (trans p3 pl 0))
                      (vlax-curve-getDistAtPoint pl (trans p1 pl 0))
                   )
                )
                (/ (- we1 (- we2 delta)) delta)
                0.01
         )
    )
  )

  (setq elst (entget pl))
  (and (= 1 (logand 1 (cdr (assoc 70 elst)))) (setq closed T))
  (setq        old-p  (vl-remove-if-not
                 (function (lambda (x) (= (car x) 10)))
                 elst
               )
        old-sw (vl-remove-if-not
                 (function (lambda (x) (= (car x) 40)))
                 elst
               )
        old-ew (vl-remove-if-not
                 (function (lambda (x) (= (car x) 41)))
                 elst
               )
        old-b  (vl-remove-if-not
                 (function (lambda (x) (= (car x) 42)))
                 elst
               )
        elst   (vl-remove-if
                 (function (lambda (x) (member (car x) '(10 40 41 42))))
                 elst
               )
  )
  (and closed (setq old-p (append old-p (list (car old-p)))))
  (while (cddr old-p)
    (if        (or (= (cdar old-sw)
               (cdar old-ew)
               (cdadr old-sw)
               (cdadr old-ew)
            )
            (regular-width
              (cdar old-p)
              (cdadr old-p)
              (cdaddr old-p)
              (cdar old-sw)
              (cdar old-ew)
              (cdadr old-sw)
              (cdadr old-ew)
            )
        )
      (if (and (zerop (cdar old-b))
               (zerop (cdadr old-b))
          )
        (if
          (if tt
            (null (inters (cdar old-p)
                          (cdaddr old-p)
                          (cdar old-p)
                          (cdadr old-p)
                  )
            )
            (betweenp (cdar old-p) (cdaddr old-p) (cdadr old-p))
          )
           (setq old-p        (cons (car old-p) (cddr old-p))
                 old-b        (cons (car old-b) (cddr old-b))
                 old-sw        (cons (car old-sw) (cddr old-sw))
                 old-ew        (cons (cadr old-ew) (cddr old-ew))
           )
           (setq new-p        (cons (car old-p) new-p)
                 new-b        (cons (car old-b) new-b)
                 new-sw        (cons (car old-sw) new-sw)
                 new-ew        (cons (car old-ew) new-ew)
                 old-p        (cdr old-p)
                 old-b        (cdr old-b)
                 old-sw        (cdr old-sw)
                 old-ew        (cdr old-ew)
           )
        )
        (if
          (and
            (/= 0.0 (cdar old-b))
            (/= 0.0 (cdadr old-b))
            (equal (caddr
                     (setq
                       b1 (BulgeData (cdar old-b) (cdar old-p) (cdadr old-p))
                     )
                   )
                   (caddr
                     (setq b2
                            (BulgeData (cdadr old-b) (cdadr old-p) (cdaddr old-p))
                     )
                   )
                   1e-4
            )
            (or        tt
                (or (and (< 0 (car b1)) (< 0 (car b2)))
                    (and (< (car b1) 0) (< (car b2) 0))
                )
            )
          )
           (setq old-p        (cons (car old-p) (cddr old-p))
                 old-b        (cons (cons 42 (tan (/ (+ (car b1) (car b2)) 4.0)))
                              (cddr old-b)
                        )
                 old-sw        (cons (car old-sw) (cddr old-sw))
                 old-ew        (cons (cadr old-ew) (cddr old-ew))
           )
           (setq new-p        (cons (car old-p) new-p)
                 new-b        (cons (car old-b) new-b)
                 new-sw        (cons (car old-sw) new-sw)
                 new-ew        (cons (car old-ew) new-ew)
                 old-p        (cdr old-p)
                 old-b        (cdr old-b)
                 old-sw        (cdr old-sw)
                 old-ew        (cdr old-ew)
           )
        )
      )
      (setq new-p  (cons (car old-p) new-p)
            new-b  (cons (car old-b) new-b)
            new-sw (cons (car old-sw) new-sw)
            new-ew (cons (car old-ew) new-ew)
            old-p  (cdr old-p)
            old-b  (cdr old-b)
            old-sw (cdr old-sw)
            old-ew (cdr old-ew)
      )
    )
  )
  (if closed
    (setq new-p (reverse (append (cdr (reverse old-p)) new-p)))
    (setq new-p (append (reverse new-p) old-p))
  )
  (setq        new-b  (append (reverse new-b) old-b)
        new-sw (append (reverse new-sw) old-sw)
        new-ew (append (reverse new-ew) old-ew)
  )
  (entmod
    (append elst
            (apply 'append
                   (apply 'mapcar
                          (cons 'list (list new-p new-sw new-ew new-b))
                   )
            )
    )
  )
)

;;; VEC1 Returns the single unit vector from p1 to p2

(defun vec1 (p1 p2 / d)
  (if (not (zerop (setq d (distance p1 p2))))
    (mapcar '(lambda (x1 x2) (/ (- x2 x1) d)) p1 p2)
  )
)

;; BETWEENP Evaluates if pt is between p1 et p2

(defun betweenp        (p1 p2 pt)
  (or (equal p1 pt 1e-9)
      (equal p2 pt 1e-9)
      (equal (vec1 p1 pt) (vec1 pt p2) 1e-9)
  )
)

;;; TRUNC Returns the list from the first item to the first occurrence
;;; of expression de l'expression (complementary to MEMBER list)

(defun trunc (expr lst)
  (if (and lst
           (not (equal (car lst) expr))
      )
    (cons (car lst) (trunc expr (cdr lst)))
  )
)

;; BulgeData Returns a 'bulge datas list' (angle radius center)
(defun BulgeData (bu p1 p2 / ang rad)
  (setq        ang (* 2 (atan bu))
        rad (/ (distance p1 p2)
               (* 2 (sin ang))
            )
        cen (polar p1
                   (+ (angle p1 p2) (- (/ pi 2) ang))
                   rad
            )
  )
  (list (* ang 2.0) rad cen)
)

;; TAN Returns the angle tangent

(defun tan (ang)
  (/ (sin ang) (cos ang))
) [/pcode]

XDSoft

Free-Lancer 发表于 2013-5-4 18:33

                               
登录/注册后可看大图

增加顶点有两种情况，一是直接在线上增加，二是在线外增加，在线上增加用 GetClosestPointto 处理到 Plin ...

一般情况下，都是在线外加了，这个加的顶点也不是最终希望的地方，还需要拽夹点到捕捉到合适的位置.

XDSoft

kwok 发表于 2013-5-4 18:23

                               
登录/注册后可看大图

要是在多段线有弧的地方加点弧不变，只是加了点，那就完美了

弧线上加点，原来的弧线还不变，一般什么情况下才用到？

Free-Lancer

高版本的CAD在夹点情况下可以方便的增/删顶点

牢固

XDSoft 发表于 2013-5-4 21:35

                               
登录/注册后可看大图

一般情况下，都是在线外加了，这个加的顶点也不是最终希望的地方，还需要拽夹点到捕捉到合适的位置.

如果点加在多段线外，这个题目似乎没有什么可讨论的余地，用Vla-addvertex函数就直接加了！
如果点是加在线上，用vlax-curve-GetClosestPointto 可以精确捕捉到线上点，顶点索引通过vlax-curve-getparamatpoint函数可以计算出来，函数的index也没必要了！只是点要加在圆弧段上时，还需要重新计算一下弓弦比值！
就着这个话题，我认为，讨论一下删除多段线的重点更有意义一些！这个重点包括重复的顶点、同一直线段或圆弧段上多余的节点！希望大家就此话题继续展开讨论！

XDSoft

牢固 发表于 2013-5-4 22:35

                               
登录/注册后可看大图

如果点加在多段线外，这个题目似乎没有什么可讨论的余地，用Vla-addvertex函数就直接加了！
如果点是加在 ...

挣取大家写一个比较通用的处理各种情况的函数。我说的在多段线外是值得比较常用的地方。但函数要适应各个情况的最好。