[求助]：请教,如何在多段线上加点或删点?

fdh · 发表于 2005-11-19 10:30:29

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

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

×

请教,如何在多段线上加点或删点?

caddog · 发表于 2009-4-12 00:41:33

SORRY，忘记了一个函数

[FONT=courier new]
(defun hj:getpllist (Polyline / enType %repeat #rev-PolyLine #1 %id-PolyLine objPolyline)
;;(setq enVertex (ent
(setq objPolyline(vlax-ename->vla-object Polyline))
(setq #1 (vlax-safearray->list
(vlax-variant-value
(vla-get-Coordinates
objPolyline
)
)
)
)
(if (= (vla-get-ObjectName objPolyline) "AcDb2dPolyline")
(setq enType 3)
(setq enType 2)
)
(setq %id-PolyLine 0
%repeat (/ (length #1) enType))
(repeat %repeat
(setq #rev-polyline1 (list (nth (* %id-PolyLine enType) #1)
(nth (1+ (* %id-PolyLine enType)) #1)
))
(if (not (equal #rev-polyline1 (car #rev-PolyLine) 1e-09))
(setq #rev-PolyLine
(cons
#rev-polyline1
#rev-PolyLine
)
)
)
(setq %id-PolyLine (1+ %id-PolyLine))
) ;_end repeat
(REVERSE #rev-PolyLine)
)
[/FONT]

[FONT=courier new] 
(defun hj:getpllist (Polyline / enType %repeat #rev-PolyLine #1 %id-PolyLine objPolyline) 
  ;;(setq enVertex (ent 
  (setq objPolyline(vlax-ename->vla-object Polyline)) 
  (setq        #1 (vlax-safearray->list 
             (vlax-variant-value 
               (vla-get-Coordinates 
                 objPolyline 
               ) 
             ) 
           ) 
  ) 
  (if (= (vla-get-ObjectName objPolyline) "AcDb2dPolyline") 
    (setq enType 3) 
    (setq enType 2) 
    ) 
  (setq %id-PolyLine 0 
        %repeat (/ (length #1) enType)) 
  (repeat %repeat 
    (setq #rev-polyline1 (list (nth (* %id-PolyLine enType) #1) 
                       (nth (1+ (* %id-PolyLine enType)) #1) 
                 )) 
    (if (not (equal #rev-polyline1 (car #rev-PolyLine) 1e-09)) 
      (setq #rev-PolyLine 
             (cons 
               #rev-polyline1 
               #rev-PolyLine 
               ) 
            ) 
      ) 
    (setq %id-PolyLine (1+ %id-PolyLine)) 
  ) ;_end repeat 
  (REVERSE #rev-PolyLine) 
) 
  [/FONT]

gufengyin · 发表于 2005-11-19 23:44:35

add node pedit
del node do not know
use lsp\arx\vba or other

vv00 · 发表于 2009-4-7 15:52:53

也问问比较方便的办法

caddog · 发表于 2009-4-8 23:55:51

这是我自己写的一个命令，献献丑

[FONT=courier new]
;;;--------------------------------------------------------
;;;函数： c:ad
;;;--------------------------------------------------------
;;;来源：　作者: caddog
;;;编制时间：2007.3
;;;功能: 添加多段线的顶点
;;;语法:
;;;参数
;;;返回值:
;;;备注 : 学习VBA看到ADDVERTEX,试着写了一个看看
;;;--------------------------------------------------------
(DEFUN C:ad (/ 2dp ename n obj p pp ss1 ss2 t1 var2dp StartWidth
endWidth ss2Type #sortVertex)
(SETQ SS1 (ENTSEL "\n请选择一条多段线:"))
(SETQ ENAME (CAR SS1))
(SETQ OBJ (VLAX-ENAME->VLA-OBJECT ENAME))
(setq ss2Type (VLA-GET-OBJECTNAME obj))
;;如果是多段线则处理
(IF (WCMATCH ss2Type "LWPOLYLINE,AcDbPolyline,POLYLINE,AcDb2dPolyline") ; _
; 结束wcmatch
(PROGN
;;显示多段线的夹点,便于用户查看
(SETQ ss2 (SSADD ENAME))
(SSSETFIRST NIL ss2)
;;提示用户选择插入点
(SETQ P (GETPOINT "\n请选择插入点:"))
;;当点P有值时循环
(WHILE p
;;确定用户所指定的插入点的位置,是在哪个顶点之后
(SETQ PP (VLAX-CURVE-GETCLOSESTPOINTTO OBJ (TRANS P 1 0)))
(SETQ N (+ (FIX (VLAX-CURVE-GETPARAMATPOINT OBJ PP)) 1))
;;取插入点外原来的起始宽度和终止宽度
;;试着用PEDIT命令添加顶点,观察加入点后宽度的变化可知
;;新加入顶点的起始/终止宽度均为原来的的终止宽度
(if (WCMATCH ss2Type "POLYLINE,AcDb2dPolyline")
(progn
;;如果是二维多段线，则不能如此简单地处理
;;二维多段线是经过了样条或按拟合的，所以先求出它的所有顶点，确定每一个
;;顶点相对于该曲线的参数，以此参数列表及PP值来求出N值 2008.8.4
(setq #sortVertex (mapcar '(lambda(x) (vlax-curve-getParamAtPoint obj (VLAX-CURVE-GETCLOSESTPOINTTO OBJ (TRANS x 1 0)))) (hj:getpllist ename)))
(setq n (1-(VL-POSITION (VLAX-CURVE-GETPARAMATPOINT OBJ PP) (vl-sort (append #sortVertex (list (VLAX-CURVE-GETPARAMATPOINT OBJ PP))) '<))) )
)
(VLA-GETWIDTH obj (- n 1) 'StartWidth 'endWidth)
)
;; 创建安全数组,并将点取的坐标赋给它.注意ADDVERTEX方法只接受二维点
(SETQ 2DP (VLAX-MAKE-SAFEARRAY VLAX-VBDOUBLE '(0 . 1)))
(VLAX-SAFEARRAY-FILL 2DP (LIST (CAR P) (CADR P)))
;;转换安全数组为变体
(SETQ VAR2DP (VLAX-MAKE-VARIANT 2DP))
;;调用ACTIVEX方法添加顶点
(if (WCMATCH ss2Type "POLYLINE,AcDb2dPolyline")
(progn
(setq #vertexS(vlax-safearray->list(vlax-variant-value(vla-get-Coordinates obj))))
(setq #vertexS(STD-SPLIT-LIST 3 #vertexS))
(setq #vertexS(hj:insertListID n p #vertexS))
(setq #vertexS (apply 'append #vertexS))
(setq #vertexS (gp:list->variantArray #vertexS))
(vla-put-coordinates obj #vertexS)
)
(progn
(VLA-ADDVERTEX OBJ N VAR2DP)
;;调整宽度
(VLA-SETWIDTH obj n endWidth endWidth)
)
)
(SETQ P (GETPOINT "\n请选择插入点:"))
) ;_end while
(PRINC)
(SSSETFIRST NIL) ;_取消夹取的状态
) ;_end progn
(PROGN
(PRINC "\n您选择的不是多段线!")
(PRINC)
) ;_end else progn
) ;_end if
(PRINC)
) ;_end defun
(defun hj:getpllist (Polyline / enType %repeat #rev-PolyLine #1 %id-PolyLine objPolyline)
;;(setq enVertex (ent
(setq objPolyline(vlax-ename->vla-object Polyline))
(setq #1 (vlax-safearray->list
(vlax-variant-value
(vla-get-Coordinates
objPolyline
)
)
)
)
(if (= (vla-get-ObjectName objPolyline) "AcDb2dPolyline")
(setq enType 3)
(setq enType 2)
)
(setq %id-PolyLine 0
%repeat (/ (length #1) enType))
(repeat %repeat
(setq #rev-polyline1 (list (nth (* %id-PolyLine enType) #1)
(nth (1+ (* %id-PolyLine enType)) #1)
))
(if (not (equal #rev-polyline1 (car #rev-PolyLine) 1e-09))
(setq #rev-PolyLine
(cons
#rev-polyline1
#rev-PolyLine
)
)
)
(setq %id-PolyLine (1+ %id-PolyLine))
) ;_end repeat
(REVERSE #rev-PolyLine)
)
;;;按照数n将表分成许多子表
;;; STD-SPLIT-LIST splits list into sublists of maximal length n
;;; n must be > 0!
;;; Iterative version by Serge Pashkov, safer than recursive version
;;; (std-split-list 2 '(1 2 3 4 5 6)) => ((1 2) (3 4) (5 6))
(defun STD-SPLIT-LIST (n lst / ret out cnt)
(setq ret nil) ; possible VL lsa compiler bug
;; adjust cnt to set incomplete number of elements (if any) for the
;; last segment
(setq cnt (- n (rem (length lst) n)) lst (reverse lst))
(while lst
(setq ret (cons (car lst) ret) lst (cdr lst))
(if (zerop (rem (setq cnt (1+ cnt)) n))
(setq out (cons ret out) ret nil)))
(if ret (cons ret out) out))
;;;----------------------------------------------
;;;在表中指定的ID号后插入新项
;;;----------------------------------------------
(defun hj:insertListID(%id-insert newitem #lst / id-insert1%)
(setq #insert1 nil #insert2 nil)
(setq %id-insert1 0)
(setq !length (length #lst))
;;取前段
(repeat (1+ %id-insert)
(setq #insert1(cons (nth %id-insert1 #lst) #insert1))
(setq %id-insert1 (1+ %id-insert1))
)
;;取后段
(setq %id-insert1 (1+ %id-insert))
(repeat (- !length %id-insert1)
(setq #insert2(cons (nth %id-insert1 #lst) #insert2))
(setq %id-insert1 (1+ %id-insert1))
)
;;组合
(REVERSE(append (append #insert2 (list newitem)) #insert1))
)
;;;取处VLISP教程
;;;----------------------------------------------
;;;gp:list->variantArray 函数中执行了如下操作：
;;;
;;;调用了 vlax-make-safearray 函数来为双精度数组 vlax-vbdouble 分配空间。
;;;vlax-make-safearray 函数还要求您指定数组下标的上下边界。
;;;在 gp:list->variantArray 中，调用 vlax-make-safearray 创建的数组的起始下标为 0，
;;;而下标上界为传给它的元素（ptsList）数目减 1。
;;; 调用 vlax-safearray-fill 函数将数组中的元素设置为点表中的相应元素。
;;;
;;;调用 vlax-make-variant 函数将 safearray 转换成变体。在 gp:list->variantArray
;;;完成最后一个函数调用后，将返回值传给调用它的函数。
(DEFUN gp:list->variantArray (ptsList / arraySpace sArray)
; 给以双精度实数表示的二维点数组分配空间
(SETQ arraySpace
(VLAX-MAKE-SAFEARRAY
VLAX-VBDOUBLE ; 元素类型
(CONS 0
(- (LENGTH ptsList) 1)
) ; 数组维数
) ;_ 结束vlax-make-safearray
) ;_ 结束setq
(SETQ sArray (VLAX-SAFEARRAY-FILL arraySpace ptsList))
; 返回数组变体
(VLAX-MAKE-VARIANT sArray)
) ;_ 结束defun
[/FONT]

[FONT=courier new] 
;;;-------------------------------------------------------- 
;;;函数： c:ad 
;;;-------------------------------------------------------- 
;;;来源：           　作者: caddog 
;;;编制时间：2007.3 
;;;功能:     添加多段线的顶点 
;;;语法:      
;;;参数       
;;;返回值:    
;;;备注  :   学习VBA看到ADDVERTEX,试着写了一个看看 
;;;-------------------------------------------------------- 
(DEFUN C:ad  (/        2dp ename n obj        p pp ss1 ss2 t1        var2dp StartWidth 
              endWidth ss2Type #sortVertex) 
  (SETQ SS1 (ENTSEL "\n请选择一条多段线:")) 
  (SETQ ENAME (CAR SS1)) 
  (SETQ OBJ (VLAX-ENAME->VLA-OBJECT ENAME)) 
  (setq ss2Type (VLA-GET-OBJECTNAME obj)) 
  ;;如果是多段线则处理 
  (IF (WCMATCH ss2Type "LWPOLYLINE,AcDbPolyline,POLYLINE,AcDb2dPolyline") ; _ 
                                                                   ; 结束wcmatch 
    (PROGN 
      ;;显示多段线的夹点,便于用户查看        
      (SETQ ss2 (SSADD ENAME)) 
      (SSSETFIRST NIL ss2) 
      ;;提示用户选择插入点 
      (SETQ P (GETPOINT "\n请选择插入点:")) 
      ;;当点P有值时循环 
      (WHILE p 
        ;;确定用户所指定的插入点的位置,是在哪个顶点之后 
        (SETQ PP (VLAX-CURVE-GETCLOSESTPOINTTO OBJ (TRANS P 1 0))) 
        (SETQ N (+ (FIX (VLAX-CURVE-GETPARAMATPOINT OBJ PP)) 1)) 
        ;;取插入点外原来的起始宽度和终止宽度 
        ;;试着用PEDIT命令添加顶点,观察加入点后宽度的变化可知 
        ;;新加入顶点的起始/终止宽度均为原来的的终止宽度 
        (if (WCMATCH ss2Type "POLYLINE,AcDb2dPolyline") 
          (progn 
            ;;如果是二维多段线，则不能如此简单地处理 
            ;;二维多段线是经过了样条或按拟合的，所以先求出它的所有顶点，确定每一个 
            ;;顶点相对于该曲线的参数，以此参数列表及PP值来求出N值 2008.8.4 
            (setq #sortVertex (mapcar '(lambda(x) (vlax-curve-getParamAtPoint obj (VLAX-CURVE-GETCLOSESTPOINTTO OBJ (TRANS x 1 0)))) (hj:getpllist ename))) 
            (setq n  (1-(VL-POSITION (VLAX-CURVE-GETPARAMATPOINT OBJ PP) (vl-sort (append #sortVertex (list (VLAX-CURVE-GETPARAMATPOINT OBJ PP))) '<)))        ) 
             
            ) 
          (VLA-GETWIDTH obj (- n 1) 'StartWidth 'endWidth) 
          ) 
        ;; 创建安全数组,并将点取的坐标赋给它.注意ADDVERTEX方法只接受二维点 
        (SETQ 2DP (VLAX-MAKE-SAFEARRAY VLAX-VBDOUBLE '(0 . 1))) 
        (VLAX-SAFEARRAY-FILL 2DP (LIST (CAR P) (CADR P))) 
        ;;转换安全数组为变体 
        (SETQ VAR2DP (VLAX-MAKE-VARIANT 2DP)) 
        ;;调用ACTIVEX方法添加顶点 
        (if (WCMATCH ss2Type "POLYLINE,AcDb2dPolyline") 
          (progn 
            (setq #vertexS(vlax-safearray->list(vlax-variant-value(vla-get-Coordinates obj)))) 
            (setq #vertexS(STD-SPLIT-LIST 3 #vertexS)) 
            (setq #vertexS(hj:insertListID n p #vertexS)) 
            (setq #vertexS (apply 'append #vertexS)) 
            (setq #vertexS (gp:list->variantArray #vertexS)) 
            (vla-put-coordinates obj #vertexS) 
            ) 
          (progn 
            (VLA-ADDVERTEX OBJ N VAR2DP) 
            ;;调整宽度 
            (VLA-SETWIDTH obj n endWidth endWidth) 
            ) 
          ) 
        
 
        (SETQ P (GETPOINT "\n请选择插入点:")) 
        ) ;_end while 
      (PRINC) 
      (SSSETFIRST NIL) ;_取消夹取的状态 
      ) ;_end progn 
    (PROGN 
      (PRINC "\n您选择的不是多段线!") 
      (PRINC) 
      ) ;_end else progn 
    ) ;_end if 
  (PRINC) 
  ) ;_end defun 
 
(defun hj:getpllist (Polyline / enType %repeat #rev-PolyLine #1 %id-PolyLine objPolyline) 
  ;;(setq enVertex (ent 
  (setq objPolyline(vlax-ename->vla-object Polyline)) 
  (setq        #1 (vlax-safearray->list 
             (vlax-variant-value 
               (vla-get-Coordinates 
                 objPolyline 
               ) 
             ) 
           ) 
  ) 
  (if (= (vla-get-ObjectName objPolyline) "AcDb2dPolyline") 
    (setq enType 3) 
    (setq enType 2) 
    ) 
  (setq %id-PolyLine 0 
        %repeat (/ (length #1) enType)) 
  (repeat %repeat 
    (setq #rev-polyline1 (list (nth (* %id-PolyLine enType) #1) 
                       (nth (1+ (* %id-PolyLine enType)) #1) 
                 )) 
    (if (not (equal #rev-polyline1 (car #rev-PolyLine) 1e-09)) 
      (setq #rev-PolyLine 
             (cons 
               #rev-polyline1 
               #rev-PolyLine 
               ) 
            ) 
      ) 
    (setq %id-PolyLine (1+ %id-PolyLine)) 
  ) ;_end repeat 
  (REVERSE #rev-PolyLine) 
) 
;;;按照数n将表分成许多子表 
;;; STD-SPLIT-LIST splits list into sublists of maximal length n 
;;; n must be > 0! 
;;; Iterative version by Serge Pashkov, safer than recursive version 
;;;   (std-split-list 2 '(1 2 3 4 5 6)) => ((1 2) (3 4) (5 6)) 
(defun STD-SPLIT-LIST (n lst / ret out cnt) 
  (setq ret nil)        ; possible VL lsa compiler bug 
  ;; adjust cnt to set incomplete number of elements (if any) for the 
  ;; last segment 
  (setq cnt (- n (rem (length lst) n)) lst (reverse lst)) 
  (while lst 
    (setq ret (cons (car lst) ret) lst (cdr lst)) 
    (if (zerop (rem (setq cnt (1+ cnt)) n)) 
      (setq out (cons ret out) ret nil))) 
  (if ret (cons ret out) out)) 
 
;;;---------------------------------------------- 
;;;在表中指定的ID号后插入新项 
;;;---------------------------------------------- 
 
(defun hj:insertListID(%id-insert newitem #lst / id-insert1%) 
  (setq #insert1 nil #insert2 nil) 
  (setq %id-insert1 0) 
  (setq !length (length #lst)) 
  ;;取前段 
  (repeat (1+ %id-insert) 
    (setq #insert1(cons (nth %id-insert1 #lst) #insert1)) 
    (setq %id-insert1 (1+ %id-insert1)) 
    ) 
  ;;取后段 
  (setq %id-insert1 (1+ %id-insert)) 
  (repeat (- !length %id-insert1) 
    (setq #insert2(cons (nth %id-insert1 #lst) #insert2)) 
    (setq %id-insert1 (1+ %id-insert1)) 
    ) 
  ;;组合 
  (REVERSE(append (append #insert2 (list newitem)) #insert1)) 
  ) 
 
;;;取处VLISP教程 
;;;---------------------------------------------- 
;;;gp:list->variantArray 函数中执行了如下操作： 
;;; 
;;;调用了 vlax-make-safearray 函数来为双精度数组 vlax-vbdouble 分配空间。 
;;;vlax-make-safearray 函数还要求您指定数组下标的上下边界。 
;;;在 gp:list->variantArray 中，调用 vlax-make-safearray 创建的数组的起始下标为 0， 
;;;而下标上界为传给它的元素（ptsList）数目减 1。 
;;;        调用 vlax-safearray-fill 函数将数组中的元素设置为点表中的相应元素。 
;;; 
;;;调用 vlax-make-variant 函数将 safearray 转换成变体。在 gp:list->variantArray 
;;;完成最后一个函数调用后，将返回值传给调用它的函数。 
 
(DEFUN gp:list->variantArray (ptsList / arraySpace sArray) 
                                        ; 给以双精度实数表示的二维点数组分配空间 
  (SETQ        arraySpace 
         (VLAX-MAKE-SAFEARRAY 
           VLAX-VBDOUBLE                ; 元素类型 
           (CONS 0 
                 (- (LENGTH ptsList) 1) 
                 )                        ; 数组维数 
           ) ;_ 结束vlax-make-safearray 
        ) ;_ 结束setq 
  (SETQ sArray (VLAX-SAFEARRAY-FILL arraySpace ptsList)) 
                                        ; 返回数组变体 
  (VLAX-MAKE-VARIANT sArray) 
 
  ) ;_ 结束defun 
  [/FONT]

carrot1983 · 发表于 2009-4-9 21:01:36

谢谢4楼的提供的代码

学习收藏~~

lrl2006 · 发表于 2009-4-9 23:03:30

直截用多义线编辑的拉直就可以了.

TLHMQH · 发表于 2009-4-11 17:20:47

[B]请教四楼[/B]
请教四楼[/COLOR]

提示：
错误: no function definition: HJ:GETPLLIST
为什么呢？

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

[求助] [求助]：请教,如何在多段线上加点或删点?

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

相关帖子