求帮助改编求最大值最小插件

lml2023

想要的效果如下：






;; 此程序用于标记一组整数中的最大值和最小值。
;; 命令：QA或QA

(vl-load-com)

;; 全局变量
(setq *QA_doc* (vla-get-activedocument (vlax-get-acad-object)))
(setq *QA_sysvar* nil)

(defun QA_savevar (varlist / var)
  (setq *QA_sysvar* nil)
  (foreach var varlist
    (setq *QA_sysvar*
           (cons (cons var (getvar var))
                 *QA_sysvar*
           )
    )
  )
)

(defun QA_resvar (/ var)
  (foreach var *QA_sysvar*
    (if        (getvar (car var))
      ;; 保证这个版本中存在这种系统变量
      (setvar (car var) (cdr var))
    )
  )
  (setq *QA_sysvar* nil)
)

(defun c:QA ()
  (vla-startundomark *QA_doc*)
  (QA_savevar '("cmdecho" "osmode"))
  (setvar "cmdecho" 0)
  (setvar "osmode" 0)
  (vl-catch-all-apply 'QA nil)
  (QA_resvar)
  (vla-endundomark *QA_doc*)
  (princ)
)

(defun QA (/ ss sslist mi ma std-sslist SelectNumbericText)
  ;; Selection Set => ordered list of entities
  (defun STD-SSLIST (ss / n lst)
    (if        (eq 'PICKSET (type ss))
      (repeat (setq n (fix (sslength ss))) ; fixed
        (setq lst (cons (ssname ss (setq n (1- n))) lst))
      )
    )
  )
  ;; 选择数字
  (defun SelectNumbericText (/ ss regexp sslist e)
    (setq regexp (vlax-create-object "Vbscript.RegExp"))
    (if        (null regexp)
      (progn
        (princ "\n正则表达式引擎初始化失败。")
        (exit)
      )
    )
    (setq ss (ssget '((0 . "*TEXT"))))
    (setq sslist (std-sslist ss))
    (vlax-put-property regexp "IgnoreCase" :vlax-true) ;忽略大小写
    (vlax-put-property regexp "Global" :vlax-true)
                                        ;匹配方式，全文字匹配
    (vlax-put-property
      regexp
      "Pattern"
      "^[-+]?[0-9]*\\.?[0-9]+\\b$"
    )
    (foreach e sslist
      (if (= :vlax-false
             (vlax-invoke-method
               regexp
               "Test"
               (cdr (assoc 1 (entget e)))
             )
          )
        (ssdel e ss)
      )
    )
    ss
  )
  ;; textbox
  (defun marktextbox (n color / nlist entlist boxlist box ptlist)
    (vl-cmdf "select" ss "")
    (setq
      nlist (std-sslist (ssget "P" (list '(0 . "*TEXT") (cons 1 n))))
    )
    (setq entlist (mapcar 'entget nlist))
    (setq boxlist (mapcar 'textbox entlist))
    (setq ptlist (mapcar '(lambda (ent) (cdr (assoc 10 ent))) entlist))
    (setq
      ptlist (mapcar '(lambda (pt) (list (car pt) (cadr pt))) ptlist)
    )
    (setq
      boxlist (mapcar '(lambda (box p)
                         (mapcar '(lambda (p1)
                                    (mapcar '+ p1 p)
                                  )
                                 box
                         )
                       )
                      boxlist
                      ptlist
              )
    )
    (foreach box boxlist
      (vl-cmdf "rectang")
      (apply 'vl-cmdf box)
      (vl-cmdf "chprop" (entlast) "" "color" color "")
    )
  )
  ;; ----------
  ;; main
  ;; ----------
  (setq ss (SelectNumbericText))
  (setq sslist (std-sslist ss))
  (setq        sslist
         (vl-sort sslist
                  (function (lambda (e1 e2)
                              (< (distof (cdr (assoc 1 (entget e1))))
                                 (distof (cdr (assoc 1 (entget e2))))
                              )
                            )
                  )
         )
  )
  (setq mi (cdr (assoc 1 (entget (car sslist)))))
  (setq ma (cdr (assoc 1 (entget (last sslist)))))
  ;; 红色标记最小值
  (marktextbox mi 3)
  ;; 绿色标记最大值
  (marktextbox ma 1)
  (princ)
)

dmxcs

(defun c:tt22 (/ prefix ss i ent txt num txt-list sorted min-ent max-ent
               min-pt max-pt min-cen max-cen min-rad max-rad ht old-clr
               filtered-txt filter)
  
  (setq old-clr (getvar 'cecolor))
  
  ;;; 正确修复前缀输入空格问题 - 使用 getstring 的 allow-spaces 参数
  (setq prefix (getstring T "\nEnter text prefix (press Enter for all text): "))
  
  ;;; 构建选择集过滤器
  (if (= prefix "")
    (setq filter '((0 . "TEXT"))) ; 如果前缀为空，选择所有文本
    (setq filter (list '(0 . "TEXT") (cons 1 (strcat prefix "*")))) ; 只选择符合前缀的文本
  )
  
  (if (setq ss (ssget filter)) ; 使用过滤器选择文本
    (progn
      (setq i 0 txt-list '())
      (repeat (sslength ss)
        (setq ent (ssname ss i)
              txt (cdr (assoc 1 (entget ent)))
              ht (cdr (assoc 40 (entget ent)))
              filtered-txt txt) ; 初始化为原始文本
        
        ;;; 处理前缀 - 如果前缀不为空，去掉前缀
        (if (/= prefix "")
          (setq filtered-txt (substr txt (+ (strlen prefix) 1)))
        )
        
        ;;; 尝试转换为数字
        (setq num (distof filtered-txt))
        
        ;;; 如果转换失败，尝试去掉可能的前导空格
        (if (not num)
          (setq num (distof (vl-string-trim " " filtered-txt)))
        )
        
        ;;; 如果成功转换为数字，添加到列表
        (if num
          (setq txt-list (cons (list num ent txt ht) txt-list))
        )
        
        (setq i (1+ i))
      )
      
      (if txt-list
        (progn
          (setq sorted (vl-sort txt-list '(lambda (x y) (< (car x) (car y))))
                min-ent (cadar sorted)
                max-ent (cadr (last sorted))
                min-ht (cadddr (car sorted))
                max-ht (cadddr (last sorted)))
         
          ;;; 处理最小值文本 - 用绿色圈
          (vla-getboundingbox (vlax-ename->vla-object min-ent) 'min-pt 'max-pt)
          (setq min-pt (vlax-safearray->list min-pt)
                max-pt (vlax-safearray->list max-pt)
                min-cen (mapcar '(lambda (a b) (* (+ a b) 0.5)) min-pt max-pt)
                min-rad (+ (* (distance min-pt max-pt) 0.5) (* min-ht 0.5)))
         
          ;;; 处理最大值文本 - 用红色圈
          (vla-getboundingbox (vlax-ename->vla-object max-ent) 'min-pt 'max-pt)
          (setq min-pt (vlax-safearray->list min-pt)
                max-pt (vlax-safearray->list max-pt)
                max-cen (mapcar '(lambda (a b) (* (+ a b) 0.5)) min-pt max-pt)
                max-rad (+ (* (distance min-pt max-pt) 0.5) (* max-ht 0.5)))
         
          ;;; 绘制圆圈 - 最小值用绿色，最大值用红色
          (setvar 'cecolor "3") ; 绿色 - 最小值
          (command "_.circle" min-cen min-rad)
         
          (setvar 'cecolor "1") ; 红色 - 最大值
          (command "_.circle" max-cen max-rad)
         
          ;;; 显示结果
          (princ (strcat "\nMin value: " (caddr (car sorted))
                        "  Max value: " (caddr (last sorted))))
          (princ (strcat "\nNumeric range: " (rtos (caar sorted))
                        " - " (rtos (car (last sorted)))))
        )
        (princ "\nNo valid numeric text found!")
      )
    )
    (princ "\nNo text objects selected!")
  )
  
  (setvar 'cecolor old-clr)
  (princ)
)

xyp1964

1. (defun c:tt ()
   
2.   (defun dxf (code e) (cdr (assoc code (entget e))))
   
3.   (defun mimx (s1 / p1 p9)
   
4.     (vla-getboundingbox (vlax-ename->vla-object s1) 'p1 'p9)
   
5.     (list (vlax-safearray->list p1) (vlax-safearray->list p9))
   
6.   )
   
7.   (defun mid (p1 p2)
   
8.     (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2)
   
9.   )
   
10.   (if (setq ss (ssget '((0 . "TEXT") (1 . "~*[~`--9]*"))))
    
11.     (progn
    
12.       (setq lst        (vl-remove-if-not '(lambda (x) (equal (type (cadr x)) 'ENAME)) (ssnamex ss))
    
13.             lst        (mapcar '(lambda (x) (list (DXF 1 x) x)) (mapcar 'cadr lst))
    
14.             lst        (vl-sort lst '(lambda (x y) (< (distof (car x)) (distof (car y)))))
    
15.             s1        (cadar lst)
    
16.             s2        (cadr (last lst))
    
17.             pn1        (mimx s1)
    
18.             pn2        (mimx s2)
    
19.             pc1        (mid (car pn1) (setq p9 (cadr pn1)))
    
20.             pc2        (mid (car pn2) (setq p9a (cadr pn2)))
    
21.       )
    
22.       (setvar 'cecolor "1")
    
23.       (command "circle" pc1 p9)
    
24.       (setq s1 (entlast))
    
25.       (setvar 'cecolor "3")
    
26.       (command "circle" pc2 p9a)
    
27.       (setq s2 (entlast))
    
28.     )
    
29.   )
    
30.   (princ)
    
31. )
    

(defun c:tt ()<br />   (defun dxf (code e) (cdr (assoc code (entget e))))<br />   (defun mimx (s1 / p1 p9)<br />     (vla-getboundingbox (vlax-ename->vla-object s1) 'p1 'p9)<br />     (list (vlax-safearray->list p1) (vlax-safearray->list p9))<br />   )<br />   (defun mid (p1 p2)<br />     (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2)<br />   )<br />   (if (setq ss (ssget '((0 . "TEXT") (1 . "~*[~`--9]*"))))<br />     (progn<br />       (setq lst        (vl-remove-if-not '(lambda (x) (equal (type (cadr x)) 'ENAME)) (ssnamex ss))<br />             lst        (mapcar '(lambda (x) (list (DXF 1 x) x)) (mapcar 'cadr lst))<br />             lst        (vl-sort lst '(lambda (x y) (< (distof (car x)) (distof (car y)))))<br />             s1        (cadar lst)<br />             s2        (cadr (last lst))<br />             pn1        (mimx s1)<br />             pn2        (mimx s2)<br />             pc1        (mid (car pn1) (setq p9 (cadr pn1)))<br />             pc2        (mid (car pn2) (setq p9a (cadr pn2)))<br />       )<br />       (setvar 'cecolor "1")<br />       (command "circle" pc1 p9)<br />       (setq s1 (entlast))<br />       (setvar 'cecolor "3")<br />       (command "circle" pc2 p9a)<br />       (setq s2 (entlast))<br />     )<br />   )<br />   (princ)<br /> )<br />

dmxcs

dmxcs 发表于 2025-11-8 10:36
(defun c:tt22 (/ prefix ss i ent txt num txt-list sorted min-ent max-ent
               min-pt max ...

可以输入指定前缀

664571221

xyp1964 发表于 2023-9-9 14:47

谢谢派大...

lml2023

xyp1964 发表于 2023-9-9 14:47

谢谢，把recteng改为circle即可

paulpipi

好用的程序，感谢分享

tomonkey239

xyp1964 发表于 2023-9-9 14:47

这个院长最拿手的

lyoshi

在改变ucs坐标后，出现了圈和数值位置不对应的情况，请问要如何解决呢？

lml2023

lyoshi 发表于 2024-8-11 16:17
在改变ucs坐标后，出现了圈和数值位置不对应的情况，请问要如何解决呢？

不要改不就可以了

lyoshi

尝试解决：把ucs坐标改回世界以后，圈的定位准确了，但圈的直径大小有些问题。PS:原来矩形框的代码无问题。

season_88

向大师学习