求帮助改编求最大值最小插件
本帖最后由 lml2023 于 2023-9-9 12:17 编辑想要的效果如下：
;; 此程序用于标记一组整数中的最大值和最小值。
;; 命令：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"
"^[-+]?*\\.?+\\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)
)
(defun c:tt ()
(defun dxf (code e) (cdr (assoc code (entget e))))
(defun mimx (s1 / p1 p9)
(vla-getboundingbox (vlax-ename->vla-object s1) 'p1 'p9)
(list (vlax-safearray->list p1) (vlax-safearray->list p9))
)
(defun mid (p1 p2)
(mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2)
)
(if (setq ss (ssget '((0 . "TEXT") (1 . "~*[~`--9]*"))))
(progn
(setq lst (vl-remove-if-not '(lambda (x) (equal (type (cadr x)) 'ENAME)) (ssnamex ss))
lst (mapcar '(lambda (x) (list (DXF 1 x) x)) (mapcar 'cadr lst))
lst (vl-sort lst '(lambda (x y) (< (distof (car x)) (distof (car y)))))
s1 (cadar lst)
s2 (cadr (last lst))
pn1 (mimx s1)
pn2 (mimx s2)
pc1 (mid (car pn1) (setq p9 (cadr pn1)))
pc2 (mid (car pn2) (setq p9a (cadr pn2)))
)
(setvar 'cecolor "1")
(command "circle" pc1 p9)
(setq s1 (entlast))
(setvar 'cecolor "3")
(command "circle" pc2 p9a)
(setq s2 (entlast))
)
)
(princ)
)
xyp1964 发表于 2023-9-9 14:47
谢谢派大... xyp1964 发表于 2023-9-9 14:47
谢谢，把recteng改为circle即可 好用的程序，感谢分享 xyp1964 发表于 2023-9-9 14:47
这个院长最拿手的 在改变ucs坐标后，出现了圈和数值位置不对应的情况，请问要如何解决呢？ lyoshi 发表于 2024-8-11 16:17
在改变ucs坐标后，出现了圈和数值位置不对应的情况，请问要如何解决呢？
不要改不就可以了 尝试解决：把ucs坐标改回世界以后，圈的定位准确了，但圈的直径大小有些问题。PS:原来矩形框的代码无问题。
页:
[1]