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

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

本帖最后由 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)
)




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

多谢楼主分享。
页: [1] 2
查看完整版本: 各种线取样提取坐标适用line,lwpolyline,polyline,spline,circle,arc,ellipse