求按列、行统计圆，并能给出数量
就像换热器布管程序那样，实现列、行统计圆的功能！搞搞 发表于 2023-4-22 20:20
能按列标数量吗？
(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))
i0
)
(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))))
)
) https://atlisp.cn/static/videos/dim-number.mp4
(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
))))
vitalgg 发表于 2023-4-21 22:00
出现：建议将(command)调用转换为(command-s)怎么解决 运行不了 本帖最后由 vitalgg 于 2023-4-21 22:39 编辑
搞搞 发表于 2023-4-21 22:21
出现：建议将(command)调用转换为(command-s)怎么解决 运行不了
执行什么命令时出现的？
可以不接受建议
vitalgg 发表于 2023-4-21 22:37
执行什么命令时出现的？
可以不接受建议
选中圆以后 右键自动退出了，出现的！ 搞搞 发表于 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)))) vitalgg 发表于 2023-4-22 06:16
需要@lisp函数库的支持。 CAD内安装了@lisp才能正确运行。
将以下代码复制到 CAD 命令行内，回车即可 ...
复制了代码，CAD命令出现：nil，失败 搞搞 发表于 2023-4-22 07:59
复制了代码，CAD命令出现：nil，失败
CAD是精减版的吗？
如果不是，加我签名后面的QQ群。
https://atlisp.cn/static/videos/dim-by-line.mp4
页:
[1]
2