求按列、行统计圆，并能给出数量

搞搞 · 发表于 2023-4-21 09:04

就像换热器布管程序那样，实现列、行统计圆的功能！

liuhe · 发表于 2023-4-21 13:34

(defun c:tt (/ E R LST I pp LST1 FUZZ SS E1 PC LST2 J P1 HLST P2 H L)
(setq e (car (ENTSEL "\n选择统计圆")))
(IF (NOT E)
(VL-EXIT-WITH-VALUE 0)
)
(SETQ R (CDR (ASSOC 40 (ENTGET E)))
LST (LIST '(0 . "CIRCLE") (CONS 40 R))
I 0
LST1 NIL
FUZZ 0
;;;;;FUZZ 是坐标点误差，等于0 或者nil 是速度会加快，要求画图精准
)
(SETQ SS (SSGET LST))
(IF (NOT SS)
(VL-EXIT-WITH-VALUE 0)
)
(SETQ PP (GETPOINT "\n统计插入点"))
(IF (NOT pp)
(VL-EXIT-WITH-VALUE 0)
)
(REPEAT (SSLENGTH SS)
(SETQ E1 (SSNAME SS I)
PC (CDR (ASSOC 10 (ENTGET E1)))
LST1 (CONS PC LST1)
I (1+ I)
)
)
(SETQ LST1 (LY:Unique LST1 FUZZ)
LST1 (LH:SORTYX LST1)
lst2 (LH:SORTXY LST1)
I 0
J 1
H 1
P1 (NTH 0 LST1)
HLST NIL
)
(REPEAT (LENGTH LST1)
(SETQ P2 (NTH (1+ I) LST1))
(IF (EQUAL (cadr P1) (cadr P2) FUZZ)
(SETQ J (1+ J))
(PROGN
(SETQ HLST (CONS (LIST H J) HLST)
H (1+ H)
P1 P2
J 1
)
)
)
(SETQ I (1+ I))
)
(SETQ
I 0
J 1
L 1
LLST NIL
P1 (NTH 0 LST2)
)
(REPEAT (LENGTH LST2)
(SETQ P2 (NTH (1+ I) LST2))
(IF (EQUAL (car P1) (car P2) FUZZ)
(SETQ J (1+ J))
(progn
(SETQ LLST (CONS (LIST L J) LLST)
L (1+ L)
P1 P2
J 1
)
)
)
;;; (If p2
;;; (Make-TEXT p2
;;; (rtos j 2 0)
;;; (* 0.2 r)
;;; )
;;; )
(SETQ I (1+ I))
)
(setq i 0)
(foreach x (reverse hlst)
(Make-TEXT (list (car pp) (- (cadr pp) (* i 2 r)))
(strcat (rtos (car x) 2 0) "行" (rtos (cadr x) 2 0) "个")
r
)
(setq i (1+ i))
)
(setq pp (polar pp 0 (* 10 r))
i 0
)
(foreach x (reverse llst)
(Make-TEXT (list (car pp) (- (cadr pp) (* i 2 r)))
(strcat (rtos (car x) 2 0) "列" (rtos (cadr x) 2 0) "个")
r
)
(setq i (1+ i))
)
(PRINC)
)
;;167.6 [功能] Entmake单行文本
(defun Make-TEXT (pt str r)
(entmakeX
(list '(0 . "TEXT") (cons 1 str) (cons 10 pt) (cons 40 r))
)
)
(DEFUN LH:SORTYX (LST)
(vl-sort LST
(function (lambda (e1 e2)
(IF (= (cadr e1) (cadr e2))
(< (car e1) (car e2))
(< (cadr e1) (cadr e2))
)
)
)
)
)
(DEFUN LH:SORTXY (LST)
(vl-sort LST
(function (lambda (e1 e2)
(IF (= (car e1) (car e2))
(< (cadr e1) (cadr e2))
(< (car e1) (car e2))
)
)
)
)
)
(defun LM:RemoveNth (n l)
;;;;去除第N项
(if (and l (< 0 n))
(cons (car l) (LM:RemoveNth (1- n) (cdr l)))
(cdr l)
)
)
(defun ly:Unique (lst fuzz / i j)
;;;;;;删除表中重复的点，有容差
(setq i 0)
(IF (OR (= FUZZ 0) (= FUZZ NIL))
(SETQ LST (LM:Unique LST))
(PROGN
(while (NTH (+ 1 i) LST)
(SETQ J (+ 1 i))
(while (NTH J LST)
(IF (MEMBER NIL
(MAPCAR '(lambda (P1 P2) (EQUAL P1 P2 fuzz))
(nth i lst)
(NTH J LST)
)
)
(setq j (+ 1 j))
(SETQ LST (LM:RemoveNth j lst))
)
)
(setq i (+ 1 i))
)
)
)
lst
)
(defun LM:Unique (l)
;;;;;;删除表中重复项无容差
(if l
(cons (car l) (LM:Unique (vl-remove (car l) (cdr l))))
)
)

(defun c:tt (/ E R LST I pp LST1 FUZZ SS E1 PC LST2 J P1 HLST P2 H L) 
  (setq e (car (ENTSEL "\n选择统计圆"))) 
  (IF (NOT E) 
    (VL-EXIT-WITH-VALUE 0) 
  ) 
  (SETQ        R    (CDR (ASSOC 40 (ENTGET E))) 
        LST  (LIST '(0 . "CIRCLE") (CONS 40 R)) 
        I    0 
        LST1 NIL 
        FUZZ 0 
;;;;;FUZZ 是坐标点误差，等于0 或者nil  是速度会加快，要求画图精准 
  ) 
  (SETQ SS (SSGET LST)) 
  (IF (NOT SS) 
    (VL-EXIT-WITH-VALUE 0) 
  ) 
  (SETQ PP (GETPOINT "\n统计插入点")) 
  (IF (NOT pp) 
    (VL-EXIT-WITH-VALUE 0) 
  ) 
  (REPEAT (SSLENGTH SS) 
    (SETQ E1   (SSNAME SS I) 
          PC   (CDR (ASSOC 10 (ENTGET E1))) 
          LST1 (CONS PC LST1) 
          I    (1+ I) 
    ) 
  ) 
  (SETQ        LST1 (LY:Unique LST1 FUZZ) 
        LST1 (LH:SORTYX LST1) 
        lst2 (LH:SORTXY LST1) 
        I    0 
        J    1 
        H    1 
        P1   (NTH 0 LST1) 
        HLST NIL 
  ) 
  (REPEAT (LENGTH LST1) 
    (SETQ P2 (NTH (1+ I) LST1)) 
    (IF        (EQUAL (cadr P1) (cadr P2) FUZZ) 
      (SETQ J (1+ J)) 
      (PROGN 
        (SETQ HLST (CONS (LIST H J) HLST) 
              H           (1+ H) 
              P1   P2 
              J           1 
        ) 
      ) 
    ) 
    (SETQ I (1+ I)) 
  ) 
  (SETQ 
    I         0 
    J         1 
    L         1 
    LLST NIL 
    P1         (NTH 0 LST2) 
  ) 
  (REPEAT (LENGTH LST2) 
    (SETQ P2 (NTH (1+ I) LST2)) 
    (IF        (EQUAL (car P1) (car P2) FUZZ) 
      (SETQ J (1+ J)) 
      (progn 
        (SETQ LLST (CONS (LIST L J) LLST) 
              L           (1+ L) 
              P1   P2 
              J           1 
        ) 
      ) 
    ) 
;;;    (If        p2 
;;;      (Make-TEXT p2 
;;;                 (rtos j 2 0) 
;;;                 (* 0.2 r) 
;;;      ) 
;;;    ) 
    (SETQ I (1+ I)) 
  ) 
  (setq i 0) 
  (foreach x (reverse hlst) 
    (Make-TEXT (list (car pp) (- (cadr pp) (* i 2 r))) 
               (strcat (rtos (car x) 2 0) "行" (rtos (cadr x) 2 0) "个") 
               r 
    ) 
    (setq i (1+ i)) 
  ) 
  (setq        pp (polar pp 0 (* 10 r)) 
        i  0 
  ) 
  (foreach x (reverse llst) 
    (Make-TEXT (list (car pp) (- (cadr pp) (* i 2 r))) 
               (strcat (rtos (car x) 2 0) "列" (rtos (cadr x) 2 0) "个") 
               r 
    ) 
    (setq i (1+ i)) 
  ) 
  (PRINC) 
) 
 
;;167.6 [功能] Entmake单行文本 
(defun Make-TEXT (pt str r) 
  (entmakeX 
    (list '(0 . "TEXT") (cons 1 str) (cons 10 pt) (cons 40 r)) 
  ) 
) 
 
 
(DEFUN LH:SORTYX (LST) 
  (vl-sort LST 
           (function (lambda (e1 e2) 
                       (IF (= (cadr e1) (cadr e2)) 
                         (< (car e1) (car e2)) 
                         (< (cadr e1) (cadr e2)) 
                       ) 
                     ) 
           ) 
  ) 
) 
(DEFUN LH:SORTXY (LST) 
  (vl-sort LST 
           (function (lambda (e1 e2) 
                       (IF (= (car e1) (car e2)) 
                         (< (cadr e1) (cadr e2)) 
                         (< (car e1) (car e2)) 
                       ) 
                     ) 
           ) 
  ) 
) 
 
 
 
(defun LM:RemoveNth (n l) 
;;;;去除第N项 
  (if (and l (< 0 n)) 
    (cons (car l) (LM:RemoveNth (1- n) (cdr l))) 
    (cdr l) 
  ) 
) 
(defun ly:Unique (lst fuzz / i j) 
;;;;;;删除表中重复的点，有容差 
  (setq i 0) 
  (IF (OR (= FUZZ 0) (= FUZZ NIL)) 
    (SETQ LST (LM:Unique LST)) 
    (PROGN 
      (while (NTH (+ 1 i) LST) 
        (SETQ J (+ 1 i)) 
        (while (NTH J LST) 
          (IF (MEMBER NIL 
                      (MAPCAR '(lambda (P1 P2) (EQUAL P1 P2 fuzz)) 
                              (nth i lst) 
                              (NTH J LST) 
                      ) 
              ) 
            (setq j (+ 1 j)) 
            (SETQ LST (LM:RemoveNth j lst)) 
          ) 
        ) 
        (setq i (+ 1 i)) 
      ) 
    ) 
  ) 
  lst 
) 
 
 
 
 
(defun LM:Unique (l) 
;;;;;;删除表中重复项无容差 
  (if l 
    (cons (car l) (LM:Unique (vl-remove (car l) (cdr l)))) 
  ) 
)

vitalgg · 发表于 2023-4-21 22:00

如果无法播放，请点击此处在新窗口打开

(defun C:dimcn ()
;; 选择小圆
(setq ss-c (pickset:to-list (ssget '((0 . "circle")(-4 . "<")(40 . 20)))))
;; 按 Y 从上到下排序
(setq ss-c (pickset:sort ss-c "Yx" 0.1))
;; 对选中的圆以Y轴进行分组,本例为当两个圆的圆心坐标Y值相差不大于1/10半径时为一组。
(setq group-c (list:group-by ss-c
'(lambda (x y)
(equal
(cadr (entity:getdxf x 10))
(cadr (entity:getdxf y 10))
(* 0.1 (entity:getdxf x 40))))))
;; 标记每组圆的个数
(if group-c
(progn
(setq pt (getpoint "标注位置"))
(mapcar
'(lambda (x)
(entity:make-text (itoa (length x))
(list (car pt) (cadr (entity:getdxf (car x) 10)) 0)
(* 2 (entity:getdxf (car x) 40))
0 0.8 0 "RM"))
group-c
))))

xyp1964 · 发表于 2023-4-22 16:50

(defun c:tt ()
"按行统计圆数量"
(xyp-Start)
(xyp-Ctbl (/ 3 3.))
(if (setq ss(ssget '((0 . "CIRCLE"))))
(setq lst(xyp-Ss2List ss)
lst (mapcar '(lambda (x) (cadr (xyp-DXF 10 x))) lst)
lst (xyp-list-count lst)
dx (+ (car (xyp-9pt ss 9)) 3)
aa (mapcar '(lambda (x)
(setq p1 (list dx (car x))
p2 (xyp-Pt2X p1 5)
s1 (xyp-Line p1 p2)
s2 (xyp-Text 4 p2 (itoa (cadr x)))
)
)
lst
)
)
)
(xyp-End)
)

搞搞 · 发表于 2023-4-21 22:21

vitalgg 发表于 2023-4-21 22:00

出现：建议将(command)调用转换为(command-s)怎么解决运行不了

vitalgg · 发表于 2023-4-21 22:37

本帖最后由 vitalgg 于 2023-4-21 22:39 编辑

搞搞发表于 2023-4-21 22:21
出现：建议将(command)调用转换为(command-s)怎么解决运行不了

执行什么命令时出现的？

可以不接受建议

搞搞 · 发表于 2023-4-21 23:00

vitalgg 发表于 2023-4-21 22:37
执行什么命令时出现的？

可以不接受建议

选中圆以后右键自动退出了，出现的！

vitalgg · 发表于 2023-4-22 06:16

搞搞发表于 2023-4-21 23:00
选中圆以后右键自动退出了，出现的！

需要@lisp函数库的支持。 CAD内安装了@lisp才能正确运行。

将以下代码复制到 CAD 命令行内，回车即可开始安装。
(在代码行里用鼠标连续三击全选，然后右键复制或Ctrl+C 。到CAD命令行内,右键粘贴或Ctrl+V)

(progn(vl-load-com)(setq s strcat h "http" o(vlax-create-object (s"win"h".win"h"request.5.1"))v vlax-invoke e eval r read)(v o'open "get" (s h"://atlisp.""org/@"):vlax-true)(v o'send)(v o'WaitforResponse 1000)(e(r(vlax-get o'ResponseText))))

搞搞 · 发表于 2023-4-22 07:59

vitalgg 发表于 2023-4-22 06:16
需要@lisp函数库的支持。 CAD内安装了@lisp才能正确运行。

将以下代码复制到 CAD 命令行内，回车即可 ...

复制了代码，CAD命令出现：nil，失败

vitalgg · 发表于 2023-4-22 08:41

搞搞发表于 2023-4-22 07:59
复制了代码，CAD命令出现：nil，失败

CAD是精减版的吗？
如果不是，加我签名后面的QQ群。

vitalgg · 发表于 2023-4-22 10:40

如果无法播放，请点击此处在新窗口打开

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

[源码] 求按列、行统计圆，并能给出数量

本帖子中包含更多资源

本帖子中包含更多资源