zhufeng1004 发表于 2025-2-1 22:00:55

圆弧改圆，删除重复圆


(defun c:TT (/ ss i ent entData center radius existingCircles isDuplicate)
;; 提示用户选择圆弧
(prompt "\n选择要转换为圆的圆弧: ")
(setq ss (ssget '((0 . "ARC")))) ;; 只选择圆弧对象

;; 检查是否有选中的对象
(if ss
    (progn
      ;; 初始化一个列表，用于存储已创建的圆的圆心和半径
      (setq existingCircles '())

      ;; 遍历选中的每一个圆弧
      (setq i 0)
      (while (< i (sslength ss))
      (setq ent (ssname ss i)) ;; 获取当前圆弧的图元名
      (setq entData (entget ent)) ;; 获取圆弧的图元数据
      (setq center (cdr (assoc 10 entData))) ;; 获取圆弧的中心点
      (setq radius (cdr (assoc 40 entData))) ;; 获取圆弧的半径

      ;; 检查是否已经存在相同的圆
      (setq isDuplicate nil)
      (foreach circle existingCircles
          (if (and (equal center (car circle) 1e-6) ;; 比较圆心
                   (equal radius (cadr circle) 1e-6)) ;; 比较半径
            (setq isDuplicate t)
          )
      )

      ;; 如果没有重复，则创建新的圆并记录
      (if (not isDuplicate)
          (progn
            (entmake
            (list
                '(0 . "CIRCLE") ;; 图元类型为圆
                (cons 10 center) ;; 圆心
                (cons 40 radius) ;; 半径
            )
            )
            ;; 将新圆的圆心和半径添加到列表中
            (setq existingCircles (cons (list center radius) existingCircles))
          )
      )

      ;; 删除旧的圆弧
      (entdel ent)

      ;; 移动到下一个圆弧
      (setq i (1+ i))
      )
      (prompt "\n已完成圆弧到圆的转换，并删除了重复的圆。")
    )
    (prompt "\n未选择任何圆弧。")
)
(princ) ;; 静默退出
)


xyp1964 发表于 2025-2-4 10:24:48

GEGEYANG88 发表于 2025-2-2 16:23
(setq ss (ssget '((0 . "CIRCLE,ARC")))) ;; 选择圆和圆弧对象
;;这样就爽了



(defun c:tt ()
"圆弧改圆并删除重复圆"
(prompt "\n选择要处理的圆弧和圆: ")
(if (setq ss (ssget '((0 . "arc,circle"))))
    (progn
      (setq lst '()
            i   -1
            ss1 (ssadd)
      )
      (while (setq s1 (ssname ss (setq i (1+ i))))
      (setq en (entget s1)
            p0 (cdr (assoc 10 en))
            rr (cdr (assoc 40 en))
            et (cdr (assoc 0 en))
      )
      (if (not (member (setq a (list p0 rr)) lst))
          (cond ((= et "ARC")
               (entmakex (list '(0 . "CIRCLE") (cons 10 p0) (cons 40 rr)))
               (setq lst (cons a lst))
               (ssadd s1 ss1)
                )
                ((= et "CIRCLE") (setq lst (cons a lst)))
          )
          (ssadd s1 ss1)
      )
      )
      (command "erase" ss1 "")
    )
)
(princ)
)

GEGEYANG88 发表于 2025-2-1 23:02:56

好！！！！

oistre 发表于 2025-2-2 09:48:19

不能运行不能运行

GEGEYANG88 发表于 2025-2-2 11:42:51

(setq ss (ssget '((0 . "CIRCLE,ARC")))) ;; 选择圆和圆弧对象
;;这样就爽了

完整武器 发表于 2025-2-2 11:48:02

2024用了没有问题

xyp1964 发表于 2025-2-2 16:09:59

(defun c:tt ()
"圆弧改圆并删除重复圆"
(prompt "\n选择要转换为圆的圆弧: ")
(if (setq ss (ssget '((0 . "ARC"))))
    (progn
      (setq lst '()
            i   0
      )
      (while (< i (sslength ss))
      (setq en (entget (ssname ss i))
            p0 (cdr (assoc 10 en))
            rr (cdr (assoc 40 en))
      )
      (if (not (member (setq a (list p0 rr)) lst))
          (setq c1(entmake (list '(0 . "CIRCLE") (cons 10 p0) (cons 40 rr)))
                lst (cons a lst)
          )
      )
      (setq i (1+ i))
      )
      (command "erase" ss "")
    )
)
(princ)
)

GEGEYANG88 发表于 2025-2-2 16:23:37

(setq ss (ssget '((0 . "CIRCLE,ARC")))) ;; 选择圆和圆弧对象
;;这样就爽了

GEGEYANG88 发表于 2025-2-2 16:56:05

(setq ss (ssget '((0 . "CIRCLE,ARC")))) ;; 选择圆和圆弧对象，可以严格保证”圆弧改圆，删除重复圆“逻辑

oistre 发表于 2025-2-8 14:36:09


好！！！！
页: [1] 2
查看完整版本: 圆弧改圆，删除重复圆