各种线取样提取坐标适用line,lwpolyline,polyline,spline,circle,arc,ellipse

wzg356 · 发表于 2020-11-26 21:13:46

本帖最后由 wzg356 于 2020-11-27 21:47 编辑

20201127更新，小改了一点点
;采集线坐标
;直线段间不取样，曲线段按长度相似度0.9999加密取样
;;;;WZG356 by 20181129
;;适用"line,lwpolyline,polyline,spline,circle,arc,ellipse"

;对顶点拟合或样条曲线化的多线段/样条曲线也可直接取样提取实际位置坐标

;速度尚可, 曲线段万点取样耗时不大于1.5秒

;无弧段多线段取样结果与coordinates法等等正常取值结果一致，速度影响轻微

;lwpolyline,polyline,circle,arc,ellipse弧段用角度法取点速度更快，不在此例

;;示例(outcurvept (car(entsel "\n选择对象: ")))

(defun outcurvept (en / n l ls1 ls2 lo po a b p1 p2 p11 p22)
(setq ob (vlax-ename->vla-object en))
(setq ls1(list(cons 0.0(vlax-curve-getstartpoint ob))))
(if (wcmatch (vla-get-objectname ob) "*Polyline")
(setq n 0
x(while ;x仅匹配setq格式用
(setq po(vlax-curve-getpointatparam ob (setq n (1+ n))))
(setq l (vlax-curve-getDistAtParam ob n))
(setq ls2(append ls2(list(cons l po))));距离+坐标
)
)
(setq l(vlax-curve-getDistAtParam ob (vlax-curve-getendparam ob))
ls2(list(cons l(vlax-curve-getendpoint ob)))
);line,spline,circle,arc,ellipse
)
(while
(setq p11(last ls1) p22(car ls2))
(setq a (car p11) b (- (car p22) a))
(setq p1 (cdr p11) p2(cdr p22))
(if (equal b(distance p1 p2) 1e-5);直线段不管
(setq ls2(cdr ls2) ls1(append ls1 (list p22)))
(setq lo (+(setq b(* b 0.5))a)
po(vlax-curve-getPointAtDist ob lo);中间点
x (if (< (* b 0.9999) (distance p1 po))
(setq ls2(cdr ls2) ls1(append ls1(list p22)))
(setq ls2 (cons(cons lo po)ls2))
)
)
)
);循环自适应
(mapcar 'cdr ls1)
)

(defun outcurvept (en / n l ls1 ls2 lo po a b p1 p2 p11 p22) 
  (setq ob (vlax-ename->vla-object en)) 
  (setq ls1(list(cons 0.0(vlax-curve-getstartpoint ob))))   
  (if  (wcmatch (vla-get-objectname ob) "*Polyline") 
    (setq n 0 
        x(while ;x仅匹配setq格式用 
            (setq po(vlax-curve-getpointatparam ob (setq n  (1+ n)))) 
            (setq l  (vlax-curve-getDistAtParam ob n)) 
            (setq ls2(append ls2(list(cons l po))));距离+坐标 
        ) 
    ) 
    (setq l(vlax-curve-getDistAtParam ob (vlax-curve-getendparam ob)) 
      ls2(list(cons l(vlax-curve-getendpoint ob))) 
    );line,spline,circle,arc,ellipse 
  )   
  (while 
    (setq p11(last ls1)  p22(car ls2)) 
    (setq a  (car p11)  b  (- (car p22) a)) 
    (setq p1 (cdr p11)  p2(cdr p22)) 
    (if  (equal b(distance p1 p2) 1e-5);直线段不管 
      (setq ls2(cdr ls2) ls1(append ls1 (list p22))) 
      (setq lo (+(setq b(* b 0.5))a) 
          po(vlax-curve-getPointAtDist ob lo);中间点 
          x (if  (< (* b 0.9999) (distance p1 po)) 
                (setq ls2(cdr ls2) ls1(append ls1(list p22))) 
                (setq ls2 (cons(cons lo po)ls2)) 
            ) 
      )       
    ) 
  );循环自适应 
  (mapcar 'cdr ls1) 
)

wzg356 · 发表于 2020-11-26 21:17:54

本帖最后由 wzg356 于 2020-11-28 15:30 编辑

实操示例1
(command "pline" (foreach p (outcurvept (car(entsel "\n选择线对象转为非曲线化多线段: ")))(command p)))
适用化
(defun c:ctp ( / sel ss en pts p)
(princ "\n 功能:将各种曲线转为轻多线段.曲线段加密采点")
(setvar "cmdecho" 0)
(command "undo" "be")
(setq sel "LINE,*OLYLINE,SPLINE,CIRCLE,ARC,ELLIPSE")
(and(setq ss(ssget (list(cons 0 sel))))
      (setq ss(vl-remove-if 'listp(mapcar 'cadr (ssnamex ss))))
      (foreach en ss
         (setq pts (outcurvept en))
         (if  (vlax-curve-isClosed en)
         (setq pts(reverse(cons "c"(cdr(reverse pts)))))
      )
      (command "pline" (foreach p pts(command p)))
      (command "_matchprop" en (entlast) "")
      (entdel en)
)
)
(command "_undo" "_e")
(setvar "cmdecho" 1)
(princ)
)

wzg356 · 发表于 2020-11-27 18:17:46

本帖最后由 wzg356 于 2020-11-27 18:18 编辑

应用例子3
多线段圆滑
(defun c:plsm ( / p e)
      (setvar "cmdecho" 0)
      (princ "\n选取要圆滑的多线段")
      (if    (setq e(ssget ":E:S" '((0 . "*POLYLINE"))))
            (progn
                     (setq e(ssname e 0))
                     (command "PEDIT" e "s" "")
                     (command "pline" (foreach p (outcurvept e)(command p)))
                     (command "_matchprop" e (entlast) "")
                     (entdel e)
            )
      )
      (setvar "cmdecho" 1)
)

wzg356 · 发表于 2020-11-27 18:04:20

应用例子2
用多线段画1个半径20的圆
(defun c:c20 ( / p e)
(setvar "cmdecho" 0)
(and(setq p (getpoint "\n指定圆心"))
(list(command "CIRCLE" p 20))
(setq e (entlast))
(list(command "pline" (foreach p (outcurvept e)(command p))))
(entdel e)
)
(setvar "cmdecho" 1)
)

songyujie928 · 发表于 2020-11-27 08:52:16

学习了

Zhouwl · 发表于 2020-11-27 23:38:18

先学习学习

tigcat · 发表于 2020-12-1 12:09:14

楼主写了关于坐标很多的好程序，支持

htlaser · 发表于 2021-10-29 16:06:08

好函数刚好能用上收藏了谢谢!!!

ZYX2129 · 发表于 2022-12-3 20:26:08

比较冷门，但是很专业

统一网名 · 发表于 2022-12-8 15:37:40

多谢楼主分享。

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

[源码] 各种线取样提取坐标适用line,lwpolyline,polyline,spline,circle,arc,ellipse

评分