1. (defun $point->Polyline->reg->centroid$
  2.        (pts lst / centroid doc obj obj1 obj2 mp tmp)
  3.           ;坐标集求质心
  4.   (setq pts (vl-remove nil pts))
  5.   (setq  pts (mapcar (function (lambda (a) (list (car a) (cadr a))))
  6.         pts
  7.       )
  8.   )
  9.   (SETQ pts (APPLY 'APPEND pts))
  10.   (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  11.   (if (= (getvar 'ctab) "Model")
  12.     (setq mp (vla-get-modelSpace doc))
  13.     (setq mp (vla-get-paperSpace doc))
  14.   )
  15.   (and pts
  16.        (setq tmp (vl-catch-all-apply
  17.        'vlax-make-safearray
  18.        (LIST vlax-vbDouble
  19.        (cons 0 (- (length pts) 1))
  20.        )
  21.      )
  22.        )
  23.        (vl-catch-all-apply 'vlax-safearray-fill (LIST tmp pts))
  24.   )
  25.   (and doc
  26.        tmp
  27.        (setq
  28.    obj1
  29.     (vl-catch-all-apply
  30.       'vla-addLightweightPolyline
  31.       (LIST mp tmp)
  32.     )
  33.        )
  34.        (not (vl-catch-all-error-p obj1))
  35.        (progn (vl-catch-all-apply 'vla-Put-CLOSED (LIST obj1 1)) t)
  36.        (setq
  37.    OBJ2 (vl-catch-all-apply
  38.     'vla-addRegion
  39.     (list
  40.       mp
  41.       (vl-catch-all-apply
  42.         'vlax-make-variant
  43.         (list
  44.           (vl-catch-all-apply
  45.       'vlax-safearray-fill
  46.       (list
  47.         (vlax-make-safearray vlax-vbObject '(0 . 0))
  48.         (list obj1)
  49.       )
  50.           )
  51.         )
  52.       )
  53.     )
  54.         )
  55.        )
  56.        (not (vl-catch-all-error-p OBJ2))
  57.        (setq obj (car (vlax-safearray->list (vlax-variant-value obj2))))
  58.        (not (vl-catch-all-error-p obj))
  59.        (setq
  60.    centroid (vlax-safearray->list
  61.         (vlax-variant-value
  62.           (vla-get-Centroid
  63.       obj
  64.           )
  65.         )
  66.       )
  67.        )
  68.   )
  69.   (if (and obj (not (vl-catch-all-error-p obj)))
  70.     (vl-catch-all-apply 'vla-delete (list obj))
  71.   )
  72.   (if (and obj1 (not (vl-catch-all-error-p obj1)))
  73.     (vl-catch-all-apply 'vla-delete (list obj1))
  74.   )
  75.   centroid
  76. )
  77. ;调用示例
  78. (vl-cmdf "point"
  79.    ($points->Polyline>reg>centroid$
  80.      (list (getpoint)
  81.      (getpoint)
  82.      (getpoint)
  83.      (getpoint)
  84.      )
  85.      nil
  86.    )
  87. )



网友答: 本帖最后由 yanshengjiang 于 2025-8-25 12:31 编辑

  3. 虽然保证了在线内，但或许不是质心。
  4. (Defun c:tt()
  5.   (command "point" (CENpoint(car(entsel))) )
  6.   )
  7. (defun CENpoint(e / p POLY POLY_vl Dx Dy Lp List_vert_poly list_p_int P_center dist step1 step2 e1 makep LWPoly->List grid_1 Point_int grid+ Point_center)
  8.   (defun makep(pt)
  9.     (entmake(append(list'(0 . "LWPOLYLINE")'(100 . "AcDbEntity")'(100 . "AcDbPolyline")'(8 . "0")
  10.       (cons 90(length pt))'(70 . 1))(mapcar '(lambda (x)(cons 10 x))pt))))
  11.   (defun LWPoly->List(ent / der di1 di2 inc lst par rad )
  12.     (setq par 0)
  13.     (repeat(cdr(assoc 90(entget ent)))
  14.         (if (setq der(vlax-curve-getsecondderiv ent par))
  15.             (if (equal der '(0.0 0.0 0.0) 1e-8)
  16.                 (setq lst (cons (vlax-curve-getpointatparam ent par) lst))
  17.                 (if(setq rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent par))
  18.        di1 (vlax-curve-getdistatparam ent par)
  19.        di2 (vlax-curve-getdistatparam ent (1+ par)))
  20.                     (progn
  21.                         (setq inc(/(- di2 di1)(1+(fix(* 25(/(- di2 di1)rad(+ pi pi)))))))
  22.                         (while (< di1 di2)
  23.                             (setq lst(cons (vlax-curve-getpointatdist ent di1)lst)
  24.                                   di1(+ di1 inc)))))))
  25.         (setq par(1+ par)))
  26.     lst)
  27.   (defun grid_1 (POLY_vl step1 / P1_ P2_ n P> )
  28.     (vla-getboundingbox POLY_vl 'p1 'p2)
  29.     (setq P1_ (vlax-safearray->list p1)
  30.     P2_ (vlax-safearray->list p2)
  31.     P1_ (list (car P1_) (cadr P1_))
  32.     P2_ (list (car P2_) (cadr P2_))n 0
  33.     Dx (/ (- (car P2_) (car P1_)) step1)
  34.     Dy (/ (- (cadr P2_) (cadr P1_)) step1)
  35.     P> P1_
  36.     Lp (list P1_))
  37.     (repeat (* (1+ step1) step1)
  38.         (setq P> (list (+ (car P>) Dx) (cadr P>))
  39.         Lp (cons P> Lp)n (1+ n))
  40.         (if (= n step1)
  41.             (setq n 0
  42.       P1_ (list (car P1_) (+ (cadr P1_) Dy))
  43.       P> P1_
  44.       Lp (cons P> Lp))))
  45.     (cdr Lp))
  46.   (defun Point_int ( Lp list_vert_poly / P_distant n Pr cont attr p# Pa Pa_ Pb )
  47.     (setq P_distant (list (car (getvar "extmax")) (* 2 (cadr (getvar "extmax"))))
  48.     list_p_int nil)
  49.     (foreach Pr Lp
  50.       (setq cont -1
  51.       attr 0
  52.       Pa (nth (setq cont (1+ cont)) list_vert_poly)
  53.       Pa_ Pa)
  54.         (repeat(length list_vert_poly)
  55.             (setq Pb (nth (setq cont (1+ cont)) list_vert_poly))
  56.             (if (= cont (length list_vert_poly)) (setq Pb Pa_))
  57.             (if(inters Pa Pb Pr P_distant)(setq attr (1+ attr)))
  58.             (setq Pa Pb))
  59.         (if(>(rem attr 2)0)(setq list_p_int(cons Pr list_p_int))))
  60.   list_p_int)
  61.   (defun grid+ (list_p_int / G+)
  62.     (setq G+(mapcar '(lambda ( x ) (list (+ (car x) (/ Dx 2)) (+ (cadr x) (/ Dy 2)))) list_p_int)
  63.     list_p_int(append G+ list_p_int)))
  64.   (defun Point_center (list_p_int / Pa n Pvic)
  65.     (setq Dist 0.0000001)
  66.     (setq P_center nil)
  67.     (foreach Pa list_p_int
  68.       (setq Pvic (vlax-curve-getClosestPointTo POLY_vl Pa))
  69.       (if(>(distance Pa Pvic)Dist)
  70.   (setq Dist(distance Pa Pvic)P_center Pa)))
  71.     P_center)
  72.   (if(equal(type e)'LIST)(progn(makep e)(setq e1(entlast)))(setq e1 e))
  73.   (setq step1 50)
  74.   (setq step2 25)
  75.   (setq POLY_vl (vlax-ename->vla-object e1))
  76.   (setq list_vert_poly (LWPoly->List e1))
  77.   (setq lp(grid_1 POLY_vl step1))
  78.   (setq list_p_int(grid+(Point_int lp list_vert_poly)))
  79.   (setq p(Point_center list_p_int))
  80.   (if (equal(type e)'LIST)(entdel e1))
  81.   p)




网友答:
kozmosovia 发表于 2025-8-24 09:08
几个command，5行代码就可以搞定的事，写那么长，真闲。但凡取个点集，计算凸壳再求质心，我都觉得这函数有 ...

凸壳求质心，CGAL就可以，我现在不想用CGAL了，试试lisp求质心到底什么情况

网友答: 本帖最后由 kozmosovia 于 2025-8-24 09:15 编辑

几个command，5行代码就可以搞定的事，写那么长，真闲。但凡取个点集，计算凸壳再求质心，我都觉得这函数有价值。

网友答: 本帖最后由 xyp1964 于 2025-8-24 16:30 编辑

参数 lst 跑哪里去了？
点集连线有可能自相交


网友答:
xyp1964 发表于 2025-8-24 16:16
参数 lst 跑哪里去了？

lst是属于【未来参数】

网友答: 这个容易出bug，自交的pl线，弄不出来面域

网友答:

网友答: 多段线质心和相对内部点



网友答: 如果要考虑线内和线外，CGAL是专门解决这个问题的
  • 上一篇：通用的对话框DCL赋值与取值函数
  • 下一篇：没有了
    CAD技术交流中心 | 建筑CAD | 给排水CAD | 暖通CAD | 电气CAD | 电力CAD | 机械CAD | CAD母线槽 | CAD看图
    Copyright © 2019 - 2025