高程点外围复合线并注记面积

杜阳 · 发表于 2025-2-15 17:00:37

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

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

×

高程点外围复合线并注记面积

(defun c:DB011 (/ pts hull ent)
;; 提示用户选择高程点
(setq pts (ssget '((0 . "POINT"))))
(if pts
(progn
;; 从选择集中提取所有点的坐标
(setq pts (get-points-from-ss pts))
;; 计算凸包得到最外围点
(setq hull (convex-hull pts))
;; 创建闭合的多段线
(setq ent (make-closed-polyline hull))
)
)
(princ)
)
;; 从选择集提取点的坐标
(defun get-points-from-ss (ss / i len entlist pt pts)
(setq i 0
len (sslength ss)
pts nil
)
(repeat len
(setq ent (ssname ss i)
entlist (entget ent)
pt (cdr (assoc 10 entlist))
)
(if pt
(setq pts (cons pt pts))
)
(setq i (1+ i))
)
pts
)
;; 计算凸包（Graham 扫描算法）
(defun convex-hull (points / p0 sorted-points stack)
(if (< (length points) 3)
points
(progn
;; 找到 y 坐标最小的点
(setq p0 (car (vl-sort points '(lambda (a b) (if (< (cadr a) (cadr b)) T (< (car a) (car b))))))
;; 根据极角排序
(setq sorted-points (sort-by-angle p0 (remove p0 points)))
;; 初始化栈
(setq stack (list p0 (car sorted-points)))
;; 遍历排序后的点
(foreach p (cdr sorted-points)
(while (and (>= (length stack) 2)
(<= (orientation (nth (- (length stack) 2) stack) (car (last stack)) p) 0)
)
(setq stack (reverse (cdr (reverse stack))))
)
(setq stack (cons p stack))
)
stack
)
)
)
;; 根据极角排序
(defun sort-by-angle (p0 points)
(vl-sort points '(lambda (a b) (< (angle-between p0 a) (angle-between p0 b)))))
;; 计算两点间的极角
(defun angle-between (p1 p2)
(angle p1 p2)
)
;; 判断三点的方向
(defun orientation (p q r)
(- (* (- (cadr r) (cadr p)) (- (car q) (car p)))
(* (- (cadr q) (cadr p)) (- (car r) (car p)))
)
)
;; 创建闭合的多段线
(defun make-closed-polyline (points / pline-data)
(setq pline-data
(append
'((0 . "POLYLINE") (100 . "AcDbEntity") (100 . "AcDb2dPolyline") (70 . 1))
(mapcar '(lambda (p) (list 10 p)) points)
'((0 . "SEQEND"))
)
)
(entmake pline-data)
)
(defun CONVEX-HULL (points / p0 sorted-points stack)
;; 如果点的数量少于 3 个，直接返回原点集
(if (< (length points) 3)
points
(progn
;; 找到 y 坐标最小的点，若 y 相同则取 x 最小的点作为基准点 p0
(setq p0 (car (vl-sort points '(lambda (a b) (if (< (cadr a) (cadr b)) T (< (car a) (car b))))))
;; 根据点相对于 p0 的极角对除 p0 外的点进行排序
(setq sorted-points (sort-by-angle p0 (remove p0 points)))
;; 初始化栈，将 p0 和排序后第一个点压入栈
(setq stack (list p0 (car sorted-points)))
;; 遍历排序后的点集
(foreach p (cdr sorted-points)
;; 当栈中元素不少于 2 个且当前点与栈顶两个点不构成左转关系时，弹出栈顶元素
(while (and (>= (length stack) 2)
(<= (orientation (nth (- (length stack) 2) stack) (car (last stack)) p) 0)
)
(setq stack (reverse (cdr (reverse stack))))
)
;; 将当前点压入栈
(setq stack (cons p stack))
)
;; 返回栈中的点，即凸包上的点
stack
)
)
)
;; 根据极角对除基准点外的点进行排序
(defun sort-by-angle (p0 points)
(vl-sort points '(lambda (a b) (< (angle-between p0 a) (angle-between p0 b)))))
;; 计算两点相对于基准点的极角
(defun angle-between (p1 p2)
(angle p1 p2)
)
;; 判断三点的方向，返回值大于 0 表示左转，小于 0 表示右转，等于 0 表示共线
(defun orientation (p q r)
(- (* (- (cadr r) (cadr p)) (- (car q) (car p)))
(* (- (cadr q) (cadr p)) (- (car r) (car p)))
)
)

(defun c:DB011 (/ pts hull ent) 
    ;; 提示用户选择高程点 
    (setq pts (ssget '((0 . "POINT")))) 
    (if pts 
        (progn 
            ;; 从选择集中提取所有点的坐标 
            (setq pts (get-points-from-ss pts)) 
            ;; 计算凸包得到最外围点 
            (setq hull (convex-hull pts)) 
            ;; 创建闭合的多段线 
            (setq ent (make-closed-polyline hull)) 
        ) 
    ) 
    (princ) 
) 
 
;; 从选择集提取点的坐标 
(defun get-points-from-ss (ss / i len entlist pt pts) 
    (setq i 0 
          len (sslength ss) 
          pts nil 
    ) 
    (repeat len 
        (setq ent (ssname ss i) 
              entlist (entget ent) 
              pt (cdr (assoc 10 entlist)) 
        ) 
        (if pt 
            (setq pts (cons pt pts)) 
        ) 
        (setq i (1+ i)) 
    ) 
    pts 
) 
 
;; 计算凸包（Graham 扫描算法） 
(defun convex-hull (points / p0 sorted-points stack) 
    (if (< (length points) 3) 
        points 
        (progn 
            ;; 找到 y 坐标最小的点 
            (setq p0 (car (vl-sort points '(lambda (a b) (if (< (cadr a) (cadr b)) T (< (car a) (car b)))))) 
            ;; 根据极角排序 
            (setq sorted-points (sort-by-angle p0 (remove p0 points))) 
            ;; 初始化栈 
            (setq stack (list p0 (car sorted-points))) 
            ;; 遍历排序后的点 
            (foreach p (cdr sorted-points) 
                (while (and (>= (length stack) 2) 
                            (<= (orientation (nth (- (length stack) 2) stack) (car (last stack)) p) 0) 
                     ) 
                    (setq stack (reverse (cdr (reverse stack)))) 
                ) 
                (setq stack (cons p stack)) 
            ) 
            stack 
        ) 
    ) 
) 
 
;; 根据极角排序 
(defun sort-by-angle (p0 points) 
    (vl-sort points '(lambda (a b) (< (angle-between p0 a) (angle-between p0 b))))) 
 
;; 计算两点间的极角 
(defun angle-between (p1 p2) 
    (angle p1 p2) 
) 
 
;; 判断三点的方向 
(defun orientation (p q r) 
    (- (* (- (cadr r) (cadr p)) (- (car q) (car p))) 
       (* (- (cadr q) (cadr p)) (- (car r) (car p))) 
    ) 
) 
 
;; 创建闭合的多段线 
(defun make-closed-polyline (points / pline-data) 
    (setq pline-data 
          (append 
              '((0 . "POLYLINE") (100 . "AcDbEntity") (100 . "AcDb2dPolyline") (70 . 1)) 
              (mapcar '(lambda (p) (list 10 p)) points) 
              '((0 . "SEQEND")) 
          ) 
    ) 
    (entmake pline-data) 
) 
 
(defun CONVEX-HULL (points / p0 sorted-points stack) 
    ;; 如果点的数量少于 3 个，直接返回原点集 
    (if (< (length points) 3) 
        points 
        (progn 
            ;; 找到 y 坐标最小的点，若 y 相同则取 x 最小的点作为基准点 p0 
            (setq p0 (car (vl-sort points '(lambda (a b) (if (< (cadr a) (cadr b)) T (< (car a) (car b)))))) 
            ;; 根据点相对于 p0 的极角对除 p0 外的点进行排序 
            (setq sorted-points (sort-by-angle p0 (remove p0 points))) 
            ;; 初始化栈，将 p0 和排序后第一个点压入栈 
            (setq stack (list p0 (car sorted-points))) 
            ;; 遍历排序后的点集 
            (foreach p (cdr sorted-points) 
                ;; 当栈中元素不少于 2 个且当前点与栈顶两个点不构成左转关系时，弹出栈顶元素 
                (while (and (>= (length stack) 2) 
                            (<= (orientation (nth (- (length stack) 2) stack) (car (last stack)) p) 0) 
                     ) 
                    (setq stack (reverse (cdr (reverse stack)))) 
                ) 
                ;; 将当前点压入栈 
                (setq stack (cons p stack)) 
            ) 
            ;; 返回栈中的点，即凸包上的点 
            stack 
        ) 
    ) 
) 
 
;; 根据极角对除基准点外的点进行排序 
(defun sort-by-angle (p0 points) 
    (vl-sort points '(lambda (a b) (< (angle-between p0 a) (angle-between p0 b))))) 
 
;; 计算两点相对于基准点的极角 
(defun angle-between (p1 p2) 
    (angle p1 p2) 
) 
 
;; 判断三点的方向，返回值大于 0 表示左转，小于 0 表示右转，等于 0 表示共线 
(defun orientation (p q r) 
    (- (* (- (cadr r) (cadr p)) (- (car q) (car p))) 
       (* (- (cadr q) (cadr p)) (- (car r) (car p))) 
    ) 
)

dnbc · 发表于 2025-2-16 10:56:01

楼主：你这个程序运行不了。
以下是Lee Mac和gile版的凸包生成程序

;; Clockwise-p - Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
(defun LM:Clockwise-p ( p1 p2 p3 )
(< (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
1e-8
)
)
(defun c:chull ( / i l s )
(if (setq s (ssget '((0 . "POINT,INSERT"))))
(progn
(repeat (setq i (sslength s))
(setq l (cons (cdr (assoc 10 (entget (ssname s (setq i (1- i)))))) l))
)
(setq l (LM:ConvexHull l))
(entmakex
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length l))
'(070 . 1)
'(62 . 1)
)
(mapcar '(lambda ( x ) (cons 10 x)) l)
)
)
)
)
(princ)
)
;; convhull - gile
;; Retourne la liste des points formant l'enveloppe convexe de pts
(defun convhull (pts / clockwise p0 acc)
;; Evalue si les points p1 p2 p3 tournent en sens horaire ou sont alignés
(defun clockwise (p1 p2 p3)
(< (sin (- (angle p1 p3) (angle p1 p2))) -1e-9)
)
;; recherche du pivot
(setq p0 (car pts))
(foreach p (cdr pts)
(if (or (< (cadr p) (cadr p0))
(and (= (cadr p) (cadr p0)) (< (car p) (car p0)))
)
(setq p0 p)
)
)
;; tri de la liste
(setq pts (vl-sort pts
'(lambda (p1 p2 / d1 d2 c1 c2)
(setq d1 (distance p0 p1)
d2 (distance p0 p2)
)
(if (or (= 0 d1)
(= 0 d2)
(equal (setq c1 (/ (- (car p0) (car p1)) d1))
(setq c2 (/ (- (car p0) (car p2)) d2))
1e-9
)
)
(< d1 d2)
(< c1 c2)
)
)
)
acc (list (cadr pts) (car pts))
pts (cddr pts)
)
;; supression des points ne faisant pas partie de l'enveloppe
(foreach p pts
(while (and (cdr acc) (clockwise (cadr acc) (car acc) p))
(setq acc (cdr acc))
)
(setq acc (cons p acc))
)
;; résultat retourné
(reverse acc)
)
;; Commande de test
(defun c:ch (/ ss n lst)
(if (setq ss (ssget '((0 . "POINT,INSERT"))))
(progn
(repeat (setq n (sslength ss))
(setq lst (cons (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))) lst))
)
(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
(entmake
(vl-list*
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst))
'(70 . 1)
'(62 . 5)
(mapcar '(lambda (p) (list 10 (car p) (cadr p))) (convhull lst))
)
)
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
)
)
(princ)
)

;; Clockwise-p  -  Lee Mac 
;; Returns T if p1,p2,p3 are clockwise oriented or collinear 
 
(defun LM:Clockwise-p ( p1 p2 p3 ) 
    (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1))) 
            (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1))) 
        ) 
        1e-8 
    ) 
) 
 
(defun c:chull ( / i l s ) 
    (if (setq s (ssget '((0 . "POINT,INSERT")))) 
        (progn 
            (repeat (setq i (sslength s)) 
                (setq l (cons (cdr (assoc 10 (entget (ssname s (setq i (1- i)))))) l)) 
            ) 
            (setq l (LM:ConvexHull l)) 
            (entmakex 
                (append 
                    (list 
                       '(000 . "LWPOLYLINE") 
                       '(100 . "AcDbEntity") 
                       '(100 . "AcDbPolyline") 
                        (cons 90 (length l)) 
                       '(070 . 1) 
                       '(62 . 1) 
                    ) 
                    (mapcar '(lambda ( x ) (cons 10 x)) l) 
                ) 
            ) 
        ) 
    ) 
    (princ) 
) 
 
;; convhull  -  gile 
;; Retourne la liste des points formant l'enveloppe convexe de pts 
(defun convhull (pts / clockwise p0 acc) 
 
  ;; Evalue si les points p1 p2 p3 tournent en sens horaire ou sont alignés 
  (defun clockwise (p1 p2 p3) 
    (< (sin (- (angle p1 p3) (angle p1 p2))) -1e-9) 
  ) 
 
  ;; recherche du pivot 
  (setq p0 (car pts)) 
  (foreach p (cdr pts) 
    (if (or (< (cadr p) (cadr p0)) 
            (and (= (cadr p) (cadr p0)) (< (car p) (car p0))) 
        ) 
      (setq p0 p) 
    ) 
  ) 
 
  ;; tri de la liste 
  (setq pts (vl-sort pts 
                     '(lambda (p1 p2 / d1 d2 c1 c2) 
                        (setq d1 (distance p0 p1) 
                              d2 (distance p0 p2) 
                        ) 
                        (if (or (= 0 d1) 
                                (= 0 d2) 
                                (equal (setq c1 (/ (- (car p0) (car p1)) d1)) 
                                       (setq c2 (/ (- (car p0) (car p2)) d2)) 
                                       1e-9 
                                ) 
                            ) 
                          (< d1 d2) 
                          (< c1 c2) 
                        ) 
                      ) 
            ) 
        acc (list (cadr pts) (car pts)) 
        pts (cddr pts) 
  ) 
 
  ;; supression des points ne faisant pas partie de l'enveloppe 
  (foreach p pts 
    (while (and (cdr acc) (clockwise (cadr acc) (car acc) p)) 
      (setq acc (cdr acc)) 
    ) 
    (setq acc (cons p acc)) 
  ) 
 
  ;; résultat retourné 
  (reverse acc) 
) 
 
;; Commande de test 
(defun c:ch (/ ss n lst) 
  (if (setq ss (ssget '((0 . "POINT,INSERT")))) 
    (progn 
      (repeat (setq n (sslength ss)) 
        (setq lst (cons (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))) lst)) 
      ) 
      (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) 
      (entmake 
        (vl-list* 
          '(0 . "LWPOLYLINE") 
          '(100 . "AcDbEntity") 
          '(100 . "AcDbPolyline") 
          (cons 90 (length lst)) 
          '(70 . 1) 
          '(62 . 5) 
          (mapcar '(lambda (p) (list 10 (car p) (cadr p))) (convhull lst)) 
        ) 
      ) 
      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) 
    ) 
  ) 
  (princ) 
)

dnbc · 发表于 2025-2-16 10:58:34

;; Convex Hull - Lee Mac
;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
(defun LM:ConvexHull ( lst / ch p0 )
;(setq lst pts)
(cond
( (< (length lst) 4) lst)
( (setq p0 (car lst))
(foreach p1 (cdr lst)
(if (or (< (cadr p1) (cadr p0))
(and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
)
(setq p0 p1)
)
)
(setq lst (vl-remove p0 lst))
(setq lst (append (list p0) lst))
(setq lst
(vl-sort lst
(function
(lambda ( a b / c d )
(if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
(< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
(< c d)
)
)
)
)
)
(setq ch (list (cadr lst) (car lst)))
(foreach pt (cddr lst)
(setq ch (cons pt ch))
(while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
(setq ch (cons pt (cddr ch)))
)
)
(reverse ch)
)
)
)
;; Clockwise-p - Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
(defun LM:Clockwise-p ( p1 p2 p3 )
(< (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
1e-8
)
)
(defun c:chull ( / i l s )
(if (setq s (ssget '((0 . "POINT,INSERT"))))
(progn
(repeat (setq i (sslength s))
(setq l (cons (cdr (assoc 10 (entget (ssname s (setq i (1- i)))))) l))
)
(setq l (LM:ConvexHull l))
(entmakex
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length l))
'(070 . 1)
'(62 . 1)
)
(mapcar '(lambda ( x ) (cons 10 x)) l)
)
)
)
)
(princ)
)
;; convhull - gile
;; Retourne la liste des points formant l'enveloppe convexe de pts
(defun convhull (pts / clockwise p0 acc)
;; Evalue si les points p1 p2 p3 tournent en sens horaire ou sont alignés
(defun clockwise (p1 p2 p3)
(< (sin (- (angle p1 p3) (angle p1 p2))) -1e-9)
)
;; recherche du pivot
(setq p0 (car pts))
(foreach p (cdr pts)
(if (or (< (cadr p) (cadr p0))
(and (= (cadr p) (cadr p0)) (< (car p) (car p0)))
)
(setq p0 p)
)
)
;; tri de la liste
(setq pts (vl-sort pts
'(lambda (p1 p2 / d1 d2 c1 c2)
(setq d1 (distance p0 p1)
d2 (distance p0 p2)
)
(if (or (= 0 d1)
(= 0 d2)
(equal (setq c1 (/ (- (car p0) (car p1)) d1))
(setq c2 (/ (- (car p0) (car p2)) d2))
1e-9
)
)
(< d1 d2)
(< c1 c2)
)
)
)
acc (list (cadr pts) (car pts))
pts (cddr pts)
)
;; supression des points ne faisant pas partie de l'enveloppe
(foreach p pts
(while (and (cdr acc) (clockwise (cadr acc) (car acc) p))
(setq acc (cdr acc))
)
(setq acc (cons p acc))
)
;; résultat retourné
(reverse acc)
)
;; Commande de test
(defun c:ch (/ ss n lst)
(if (setq ss (ssget '((0 . "POINT,INSERT"))))
(progn
(repeat (setq n (sslength ss))
(setq lst (cons (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))) lst))
)
(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
(entmake
(vl-list*
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst))
'(70 . 1)
'(62 . 5)
(mapcar '(lambda (p) (list 10 (car p) (cadr p))) (convhull lst))
)
)
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
)
)
(princ)
)

;; Convex Hull  -  Lee Mac 
;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points. 
 
(defun LM:ConvexHull ( lst / ch p0 ) 
    ;(setq lst pts) 
    (cond 
        (   (< (length lst) 4) lst) 
        (   (setq p0 (car lst)) 
            (foreach p1 (cdr lst) 
                (if (or (< (cadr p1) (cadr p0)) 
                        (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0))) 
                    ) 
                    (setq p0 p1) 
                ) 
            ) 
            (setq lst (vl-remove p0 lst)) 
            (setq lst (append (list p0) lst)) 
            (setq lst 
                (vl-sort lst 
                    (function 
                        (lambda ( a b / c d ) 
                              (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8)))) 
                                  (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b)) 
                                  (< c d) 
                              ) 
                        ) 
                    ) 
                ) 
            ) 
            (setq ch (list (cadr lst) (car lst))) 
            (foreach pt (cddr lst) 
                (setq ch (cons pt ch)) 
                (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt)) 
                    (setq ch (cons pt (cddr ch))) 
                ) 
            ) 
            (reverse ch) 
        ) 
    ) 
) 
 
;; Clockwise-p  -  Lee Mac 
;; Returns T if p1,p2,p3 are clockwise oriented or collinear 
 
(defun LM:Clockwise-p ( p1 p2 p3 ) 
    (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1))) 
            (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1))) 
        ) 
        1e-8 
    ) 
) 
 
(defun c:chull ( / i l s ) 
    (if (setq s (ssget '((0 . "POINT,INSERT")))) 
        (progn 
            (repeat (setq i (sslength s)) 
                (setq l (cons (cdr (assoc 10 (entget (ssname s (setq i (1- i)))))) l)) 
            ) 
            (setq l (LM:ConvexHull l)) 
            (entmakex 
                (append 
                    (list 
                       '(000 . "LWPOLYLINE") 
                       '(100 . "AcDbEntity") 
                       '(100 . "AcDbPolyline") 
                        (cons 90 (length l)) 
                       '(070 . 1) 
                       '(62 . 1) 
                    ) 
                    (mapcar '(lambda ( x ) (cons 10 x)) l) 
                ) 
            ) 
        ) 
    ) 
    (princ) 
) 
 
;; convhull  -  gile 
;; Retourne la liste des points formant l'enveloppe convexe de pts 
(defun convhull (pts / clockwise p0 acc) 
 
  ;; Evalue si les points p1 p2 p3 tournent en sens horaire ou sont alignés 
  (defun clockwise (p1 p2 p3) 
    (< (sin (- (angle p1 p3) (angle p1 p2))) -1e-9) 
  ) 
 
  ;; recherche du pivot 
  (setq p0 (car pts)) 
  (foreach p (cdr pts) 
    (if (or (< (cadr p) (cadr p0)) 
            (and (= (cadr p) (cadr p0)) (< (car p) (car p0))) 
        ) 
      (setq p0 p) 
    ) 
  ) 
 
  ;; tri de la liste 
  (setq pts (vl-sort pts 
                     '(lambda (p1 p2 / d1 d2 c1 c2) 
                        (setq d1 (distance p0 p1) 
                              d2 (distance p0 p2) 
                        ) 
                        (if (or (= 0 d1) 
                                (= 0 d2) 
                                (equal (setq c1 (/ (- (car p0) (car p1)) d1)) 
                                       (setq c2 (/ (- (car p0) (car p2)) d2)) 
                                       1e-9 
                                ) 
                            ) 
                          (< d1 d2) 
                          (< c1 c2) 
                        ) 
                      ) 
            ) 
        acc (list (cadr pts) (car pts)) 
        pts (cddr pts) 
  ) 
 
  ;; supression des points ne faisant pas partie de l'enveloppe 
  (foreach p pts 
    (while (and (cdr acc) (clockwise (cadr acc) (car acc) p)) 
      (setq acc (cdr acc)) 
    ) 
    (setq acc (cons p acc)) 
  ) 
 
  ;; résultat retourné 
  (reverse acc) 
) 
 
;; Commande de test 
(defun c:ch (/ ss n lst) 
  (if (setq ss (ssget '((0 . "POINT,INSERT")))) 
    (progn 
      (repeat (setq n (sslength ss)) 
        (setq lst (cons (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))) lst)) 
      ) 
      (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) 
      (entmake 
        (vl-list* 
          '(0 . "LWPOLYLINE") 
          '(100 . "AcDbEntity") 
          '(100 . "AcDbPolyline") 
          (cons 90 (length lst)) 
          '(70 . 1) 
          '(62 . 5) 
          (mapcar '(lambda (p) (list 10 (car p) (cadr p))) (convhull lst)) 
        ) 
      ) 
      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) 
    ) 
  ) 
  (princ) 
)

dnbc · 发表于 2025-2-17 14:58:50

本帖最后由 dnbc 于 2025-2-18 09:02 编辑

加上面积标汪

<blockquote>;; Convex Hull - Lee Mac

复制代码

happyending · 发表于 2025-8-3 00:49:59

我也顺便来学习一下。感谢大家。

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

[求助] 高程点外围复合线并注记面积

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