[原创]：一组简便实用的编辑多义线的VLISP程序(函数)

lsjjm · 发表于 2003-9-16 11:16:30

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

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

×

一组简便实用的编辑多义线的VLISP程序(函数)

;; By Richard L
;; Parker Hannifin Ltd (NZ).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 判断多义线是否3D多义线
(defun is3dpline (ename)
(setq obj (vlax-ename->vla-object ename))
(if (= (vla-get-objectname obj) "AcDb3dPolyline")
(setq 3d T)
(setq 3d nil)
)
3d
)
;; 判断多义线是否闭合
(defun isclosed (ename)
(setq obj (vlax-ename->vla-object ename))
(vla-get-closed obj)
)
;; 判断多义线是PLINE还是SPLINE
(defun plineorspline (ename)
(setq obj (vlax-ename->vla-object ename))
(cond
((or (= (vla-get-objectname obj) "AcDbPolyline")
(= (vla-get-objectname obj) "AcDb3dPolyline"))
(setq pl T))
((= (vla-get-objectname obj) "AcDbSpline")
(setq pl nil))
(T (alert "It is neither Polyline nor Spline! "))
)
pl
)
;; 返回多义线的面积
(defun getarea (ename)
(setq obj (vlax-ename->vla-object ename))
(vla-get-area obj)
);
; 返回多义线的各顶点
(defun vertexs (ename / plist pp n)
(setq obj (vlax-ename->vla-object ename))
(setq plist (vlax-safearray->list
(vlax-variant-value
(vla-get-coordinates obj))))
(setq n 0)
(repeat (/ (length plist) 2)
(setq pp (append pp (list (list (nth n plist)(nth (1+ n) plist)))))
(setq n (+ n 2))
)
pp
)
;;判断多义线是否有圆弧(凸度/=0)的子段
(defun checkarc (ename)
(setq obj (vlax-ename->vla-object ename))
(setq plist (vlax-safearray->list
(vlax-variant-value
(vla-get-coordinates obj))))
(setq n 0 bu nil)
(repeat (/ (length plist) 2)
(if (/= (vla-getbulge obj n) 0)
(setq bu T)
)
(setq n (+ n 1))
)
bu
)
;; 返回多义线子段的数量
(defun numbersofseg (ename)
(setq obj (vlax-ename->vla-object ename))
(setq plist (vlax-safearray->list
(vlax-variant-value
(vla-get-coordinates obj))))
(1- (/ (length plist) 2))
)
;; 返回多义线第n点的坐标
(defun coodsofnumpoint (ename n)
(setq obj (vlax-ename->vla-object ename))
(setq plist (vlax-safearray->list
(vlax-variant-value
(vla-get-coordinates obj))))
(list (nth (* n 2) plist)(nth (1+ (* n 2)) plist))
)
;; 返回多义线第n子段的端点坐标
(defun coodsofsegbynum (obj n)
(vlax-safearray->list
(vlax-variant-value
(vla-get-coordinate obj 2)))
)
;; 返回多义线所点击子段的端点坐标
(defun coordsofsegbypick (ename p)
(setq obj (vlax-ename->vla-object ename)
pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp)))
(segcoord obj n)
)
;;返回多义线第n个子段的长度
(defun lengthofsegbynum (ename n)
(setq obj (vlax-ename->vla-object ename))
(- (vlax-curve-getdistatparam obj (1+ n))
(vlax-curve-getdistatparam obj n))
);
;; 返回多义线所点击子段的长度
(defun lengthofseg (ename p)
(setq obj (vlax-ename->vla-object ename)
pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp)))
(- (vlax-curve-getdistatparam obj (1+ n))
(vlax-curve-getdistatparam obj n))
)
;;返回多义线第n个子段的宽度
(defun widthofsegbynum (ename n)
(setq obj (vlax-ename->vla-object ename))
(vla-getwidth obj n 'ws 'wd)
(list ws wd)
)
;; 返回多义线所点击子段的宽度
(defun widthofsegbypick (ename p)
(setq obj (vlax-ename->vla-object ename)
pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp)))
(vlax-invoke-method obj 'getwidth n 'ws 'wd)
(list ws wd)
);
;;COPY多义线所点击的子段
(defun segmentcopy (ename p)
(vl-cmdf "explode" ename "")
(vl-cmdf "copy" (ssget "c" (polar p (/ pi 4) 0.01)(polar p (* 1.25 pi) 0.01))
"" p (getpoint "\nSecond point:") "")
(setq entl (entget (entlast)))
(vl-cmdf "undo" 2 "")
(entmake (cdr entl))
)
;; OFFSET多义线所点击的子段
(defun segmentoffset (ename p)
(setq oo (getdist "\nValue of offset:"))
(vl-cmdf "explode" ename "")
(vl-cmdf "offset" oo p
; (ssname (ssget "c" (polar p (/ pi 4) 0.01)(polar p (* 1.25 pi) 0.01)) 0)
(getpoint "\nInput offset point:") "")
(setq entl (entget (entlast)))
(vl-cmdf "undo" 2 "")
(entmake (cdr entl))
)
;;修改多义线第n个子段的凸度
(defun bulgebynum (ename n)
(setq obj (vlax-ename->vla-object ename))
(setq bu (getreal "\nNew Bugle Value: "))
(vla-setbulge obj n bu)
)
;; 修改多义线所点击子段的凸度
(defun bulgebypick (ename p)
(setq obj (vlax-ename->vla-object ename)
pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp)))
(setq bu (getreal "\nNew Bugle Value: "))
(vla-setbulge obj n bu)
)
;; 给多义线添加顶点
(defun addvertex (ename p)
(setq obj (vlax-ename->vla-object ename)
pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp))
pn (getpoint "\nPick a Point: ")
pn (list (car pn)(cadr pn))
newv (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble '(0 . 1)) pn))
(vla-addvertex obj (1+ n) newv)
)

;; By Richard L 
;; Parker Hannifin Ltd (NZ). 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 
;; 判断多义线是否3D多义线 
(defun is3dpline (ename)                
  (setq obj (vlax-ename->vla-object ename)) 
  (if (= (vla-get-objectname obj) "AcDb3dPolyline") 
    (setq 3d T) 
    (setq 3d nil) 
  ) 
  3d 
) 
;; 判断多义线是否闭合 
(defun isclosed (ename)            
  (setq obj (vlax-ename->vla-object ename)) 
  (vla-get-closed obj) 
) 
;; 判断多义线是PLINE还是SPLINE 
(defun plineorspline (ename)                
  (setq obj (vlax-ename->vla-object ename)) 
  (cond 
    ((or (= (vla-get-objectname obj) "AcDbPolyline") 
         (= (vla-get-objectname obj) "AcDb3dPolyline")) 
      (setq pl T)) 
    ((= (vla-get-objectname obj) "AcDbSpline") 
     (setq pl nil)) 
    (T (alert "It is neither Polyline nor Spline! ")) 
  ) 
  pl 
) 
;; 返回多义线的面积 
(defun getarea (ename)        
  (setq obj (vlax-ename->vla-object ename)) 
  (vla-get-area obj) 
); 
; 返回多义线的各顶点 
(defun vertexs (ename / plist pp n)         
  (setq obj (vlax-ename->vla-object ename)) 
  (setq plist (vlax-safearray->list 
                (vlax-variant-value 
                  (vla-get-coordinates obj)))) 
  (setq n 0) 
  (repeat (/ (length plist) 2) 
    (setq pp (append pp (list (list (nth n plist)(nth (1+ n) plist))))) 
    (setq n (+ n 2)) 
  ) 
  pp 
) 
;;判断多义线是否有圆弧(凸度/=0)的子段 
(defun checkarc (ename)                        
  (setq obj (vlax-ename->vla-object ename)) 
  (setq plist (vlax-safearray->list 
                (vlax-variant-value 
                  (vla-get-coordinates obj)))) 
  (setq n 0 bu nil) 
  (repeat (/ (length plist) 2) 
    (if (/= (vla-getbulge obj n) 0) 
      (setq bu T) 
     ) 
    (setq n (+ n 1)) 
  ) 
  bu 
) 
;; 返回多义线子段的数量 
(defun numbersofseg (ename)                
  (setq obj (vlax-ename->vla-object ename)) 
  (setq plist (vlax-safearray->list 
                (vlax-variant-value 
                  (vla-get-coordinates obj)))) 
  (1- (/ (length plist) 2)) 
) 
;; 返回多义线第n点的坐标 
(defun coodsofnumpoint (ename n) 
  (setq obj (vlax-ename->vla-object ename)) 
  (setq plist (vlax-safearray->list 
                (vlax-variant-value 
                  (vla-get-coordinates obj)))) 
  (list (nth (* n 2) plist)(nth (1+ (* n 2)) plist)) 
) 
;; 返回多义线第n子段的端点坐标 
(defun coodsofsegbynum (obj n)                
  (vlax-safearray->list 
              (vlax-variant-value 
                (vla-get-coordinate obj 2))) 
) 
;; 返回多义线所点击子段的端点坐标 
(defun coordsofsegbypick (ename p)                
  (setq obj (vlax-ename->vla-object ename) 
         pp (vlax-curve-getclosestpointto obj (trans p 1 0)) 
          n (fix (vlax-curve-getparamatpoint obj pp))) 
  (segcoord obj n) 
) 
;;返回多义线第n个子段的长度 
 (defun lengthofsegbynum (ename n)                
  (setq obj (vlax-ename->vla-object ename)) 
  (- (vlax-curve-getdistatparam obj (1+ n)) 
     (vlax-curve-getdistatparam obj n)) 
); 
;; 返回多义线所点击子段的长度 
(defun lengthofseg (ename p)                
  (setq obj (vlax-ename->vla-object ename) 
         pp (vlax-curve-getclosestpointto obj (trans p 1 0)) 
          n (fix (vlax-curve-getparamatpoint obj pp))) 
  (- (vlax-curve-getdistatparam obj (1+ n)) 
     (vlax-curve-getdistatparam obj n)) 
) 
;;返回多义线第n个子段的宽度 
 (defun widthofsegbynum (ename n)                
  (setq obj (vlax-ename->vla-object ename)) 
  (vla-getwidth obj n 'ws 'wd) 
  (list ws wd) 
) 
;; 返回多义线所点击子段的宽度 
(defun widthofsegbypick (ename p)                
  (setq obj (vlax-ename->vla-object ename) 
         pp (vlax-curve-getclosestpointto obj (trans p 1 0)) 
          n (fix (vlax-curve-getparamatpoint obj pp))) 
  (vlax-invoke-method obj 'getwidth n 'ws 'wd) 
  (list ws wd) 
); 
;;COPY多义线所点击的子段 
(defun segmentcopy (ename p)                
  (vl-cmdf "explode" ename "") 
  (vl-cmdf "copy" (ssget "c" (polar p (/ pi 4) 0.01)(polar p (* 1.25 pi) 0.01)) 
                   "" p (getpoint "\nSecond point:") "") 
  (setq entl (entget (entlast))) 
  (vl-cmdf "undo" 2 "") 
  (entmake (cdr entl)) 
) 
;; OFFSET多义线所点击的子段 
(defun segmentoffset (ename p)                   
  (setq oo (getdist "\nValue of offset:")) 
  (vl-cmdf "explode" ename "") 
  (vl-cmdf "offset" oo p 
   ; (ssname (ssget "c" (polar p (/ pi 4) 0.01)(polar p (* 1.25 pi) 0.01)) 0) 
      (getpoint "\nInput offset point:") "") 
  (setq entl (entget (entlast))) 
  (vl-cmdf "undo" 2 "") 
  (entmake (cdr entl)) 
) 
;;修改多义线第n个子段的凸度 
(defun bulgebynum (ename n)                
  (setq obj (vlax-ename->vla-object ename)) 
  (setq  bu (getreal "\nNew Bugle Value: ")) 
  (vla-setbulge obj n bu) 
) 
;; 修改多义线所点击子段的凸度 
(defun bulgebypick (ename p)                
  (setq obj (vlax-ename->vla-object ename) 
         pp (vlax-curve-getclosestpointto obj (trans p 1 0)) 
          n (fix (vlax-curve-getparamatpoint obj pp))) 
  (setq  bu (getreal "\nNew Bugle Value: ")) 
  (vla-setbulge obj n bu) 
) 
;; 给多义线添加顶点 
(defun addvertex (ename p)                
  (setq obj (vlax-ename->vla-object ename) 
         pp (vlax-curve-getclosestpointto obj (trans p 1 0)) 
          n (fix (vlax-curve-getparamatpoint obj pp)) 
         pn (getpoint "\nPick a Point: ") 
         pn (list (car pn)(cadr pn)) 
       newv (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble '(0 . 1)) pn)) 
  (vla-addvertex obj (1+ n) newv) 
)

adsl1 · 发表于 2004-7-23 11:03:03

謝謝,不錯的程序

aeo · 发表于 2004-7-25 16:23:18

(defun widthofsegbypick (ename p)
(setq obj (vlax-ename->vla-object ename)
pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp)))
(vlax-invoke-method obj 'getwidth n 'ws 'wd)
(list ws wd)
);

对旧式的polyline应该有问题.

Free-Lancer · 发表于 2004-7-25 17:42:26

是否闭合曲线

(vlax-curve-isclosed curve)

PFD8667 · 发表于 2004-9-3 08:44:56

用什么命令使用?

urljit · 发表于 2004-10-29 20:19:28

很好的程序，值得收藏

eachy · 发表于 2004-10-29 21:05:42

利用上面的函数写了个增加顶点的程序

(vl-load-com)
;; 给多义线添加顶点
(defun addvertex (ename p / obj pp n pn newv)
(setq obj (vlax-ename->vla-object ename)
pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp))
pn (list (car p) (cadr p))
newv (vlax-safearray-fill
(vlax-make-safearray vlax-vbDouble '(0 . 1))
pn
)
)
(vla-addvertex obj (1+ n) newv)
)
(defun c:tt (/ e p1 olderr myerr)
(defun myerr (msg)
(princ msg)
(vl-cmdf ".undo" "e")
(princ)
)
(setq olderr *error*
*error* myerr
)
(vl-cmdf "undo" "be")
(if (setq e (entsel))
(while (setq p1 (getpoint "\nPick Point: "))
(addvertex (car e) p1)
)
)
(setq *error* olderr)
(vl-cmdf ".undo" "e")
(princ)
)

(vl-load-com) 
;; 给多义线添加顶点 
(defun addvertex (ename p / obj pp n pn newv) 
  (setq        obj  (vlax-ename->vla-object ename) 
        pp   (vlax-curve-getclosestpointto obj (trans p 1 0)) 
        n    (fix (vlax-curve-getparamatpoint obj pp)) 
        pn   (list (car p) (cadr p)) 
        newv (vlax-safearray-fill 
               (vlax-make-safearray vlax-vbDouble '(0 . 1)) 
               pn 
             ) 
  ) 
  (vla-addvertex obj (1+ n) newv) 
) 
(defun c:tt (/ e p1 olderr myerr) 
  (defun myerr (msg) 
    (princ msg) 
    (vl-cmdf ".undo" "e") 
    (princ) 
  ) 
  (setq        olderr        *error* 
        *error*        myerr 
  ) 
  (vl-cmdf "undo" "be") 
  (if (setq e (entsel)) 
    (while (setq p1 (getpoint "\nPick Point: ")) 
      (addvertex (car e) p1) 
    ) 
  ) 
  (setq *error* olderr) 
  (vl-cmdf ".undo" "e") 
  (princ) 
)

aeo · 发表于 2004-10-29 22:56:34

可惜没有删除顶点的方法，只好硬写.

skyhits_02 · 发表于 2004-10-29 23:45:07

能不能请楼主说明一下怎么使用法,方便大家学习.
功能是什么?

lsjjm · 发表于 2004-10-30 12:46:06

7楼: 里面有增加顶点的函数呀
8楼: 删除顶点的函数曾经贴过:
[PHP]
(defun c:test ()
  ;(vl-load-com)
  (setq p (getpoint "\npick point:"))
  (setq ent (ssname (ssget p) 0)
      obj (vlax-ename->vla-object ent))
  (setq pts (variant-value (vla-get-coordinates obj)))
  (setq nlist (vl-remove (car p)(vlax-safearray->list pts)))
  (setq nlist (vl-remove (cadr p) nlist))
  (setq narray (vlax-make-safearray
            vlax-vbDouble
         (cons 0 (1- (length nlist)))))
  (vla-put-coordinates obj (vlax-safearray-fill narray nlist))
  (princ)
)
[/PHP]

xxxyzxx · 发表于 2004-11-20 21:47:02

谢谢楼主，程序写得详尽，学到不少知识！

rat-saint · 发表于 2004-11-21 13:10:16

输什么命令使用？

aeo · 发表于 2004-11-21 15:17:12

重新又看了下:
;;COPY多义线所点击的子段
(defun segmentcopy (ename p)
  (vl-cmdf "explode" ename "")
  (vl-cmdf "copy" (ssget "c" (polar p (/ pi 4) 0.01)(polar p (* 1.25 pi) 0.01))
            "" p (getpoint "\nSecond point:") "")
  (setq entl (entget (entlast)))
  (vl-cmdf "undo" 2 "")
  (entmake (cdr entl))
)
;; OFFSET多义线所点击的子段
(defun segmentoffset (ename p)
  (setq oo (getdist "\nValue of offset:"))
  (vl-cmdf "explode" ename "")
  (vl-cmdf "offset" oo p
; (ssname (ssget "c" (polar p (/ pi 4) 0.01)(polar p (* 1.25 pi) 0.01)) 0)
   (getpoint "\nInput offset point:") "")
  (setq entl (entget (entlast)))
  (vl-cmdf "undo" 2 "")
  (entmake (cdr entl))
)

得到的是没宽度的线.
而且中间有输入点,那么(vl-cmdf "undo" 2 "")是不安全的.

wlz088 · 发表于 2004-11-21 15:56:24

如果要一条线在与另一条线相交处断开，而且两条都是多义线，如何实现？

aeo · 发表于 2004-11-21 16:24:22

最初由 wlz088 发布
[B]如果要一条线在与另一条线相交处断开，而且两条都是多义线，如何实现？ [/B]

有的，找找.

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

[原创]：一组简便实用的编辑多义线的VLISP程序(函数)

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

相关帖子