图纸自动编号改写编辑程序
本帖最后由 ld80721 于 2024-5-29 17:03 编辑程序也正确调整好，有需要的大家自取：
;; 程序设计用途：自动编号，选择需要重新编号的具有相同前缀的其中任意一个文本，
;; 使具有相同前缀的文本按照从01、02到N，从左到右，自上而下自动排序；
;; 用途：图纸页码编号等
;; 感谢明经论坛“飞雪神光”改写支持！
;; 原创程序（思路）设计：罗正环
由于本人程序编写能力太烂，好多年了没有写，基础都快没了，但是在工作实际使用中，有些心得框架，让CHAT gpt帮忙实现愿望目的，但是人与机器很难沟通，老是出现偏差理解；所以现在只能求大神们帮忙改改了，感谢！
编程需求：
想要编写一个程序，它能够在 AutoCAD 图纸空间（布局）中执行以下操作：
[*]提示用户选择一个文本对象。
[*]从所选择的文本对象中提取所有相同前缀，例如 "pl-"。
[*]使用这个前缀，找到并选择所有具有相同前缀的文本对象。
[*]对这些选定的文本对象进行排序，以确保它们按照从上到下，从左到右的顺序排列。
[*]重新编号这些文本对象，保持原始的前缀 "pl-" 不变，但将数字部分从 "01" 开始递增，确保格式为两位数。
图列：
目前我让AI写的程序为：
(defun c:RenumberText ( / ss obj cnt prefix lst sortedObjs)
;; 自定义排序函数：按从上到下，从左到右排序
(defun sort-objects (obj1 obj2)
(setq pos1 (cdr (assoc 10 (entget obj1))))
(setq pos2 (cdr (assoc 10 (entget obj2))))
(if (not (= (cadr pos1) (cadr pos2)))
(< (cadr pos1) (cadr pos2))
(< (car pos1) (car pos2))))
;; 获取前缀函数：从字符串中提取前缀
(defun get-prefix (str)
(if (and (setq idx (vl-string-search "-" str))
(> idx 0))
(substr str 1 (1- idx));; 不包含 '-' 在前缀中
nil))
;; 提示用户选择一个文本对象
(if (setq obj (car (entsel "\n请选择一个文本对象: ")))
(progn
;; 获取选定对象的前缀
(setq prefix (get-prefix (cdr (assoc 1 (entget obj)))))
(if prefix
(progn
;; 获取所有包含相同前缀的文本对象
(setq ss (ssget "X" (list (cons 0 "TEXT,MTEXT")
(cons 1 (strcat prefix "*")))))
(if ss
(progn
;; 将选择集转换为列表
(setq lst '())
(repeat (setq i (sslength ss))
(setq lst (cons (ssname ss (setq i (1- i))) lst)))
;; 对对象进行排序
(setq sortedObjs (vl-sort lst 'sort-objects))
;; 重新编号
(setq cnt 1)
(foreach obj sortedObjs
(setq text (cdr (assoc 1 (entget obj))))
(setq newText (strcat prefix (rtos cnt 2 0)))
(entmod (subst (cons 1 newText) (assoc 1 (entget obj)) (entget obj)))
(entupd obj)
(setq cnt (1+ cnt)))
(princ "\n重新编号完成."))
(princ "\n没有找到匹配的文本对象.")))
(princ "\n选定的对象没有有效的前缀."))))
(princ))
(princ "\n加载完成。请输入 RenumberText 运行程序。")
(princ)
(defun c:RenumberText (/ cnt get-prefix hh:sspts:sort lm-str-buwei newtext obj prefix ss tylst)
;|本软件为开源软件: 以下是开源申明:
-----------------------------------------------------------------------------------------------;
本页面的软件遵照GPL协议开放源代码，您可以自由传播和修改，在遵照下面的约束条件的前提下:
一. 只要你在本开源软件的每一副本上明显和恰当地出版版权声明，保持此许可证的声明和没有担保的声明完
整无损，并和程序一起给每个其他的程序接受者一份许可证的副本，你就可以用任何媒体复制和发布你收到的
原始的程序的源代码。你也可以为转让副本的实际行动收取一定费用，但必须事先得到的同意。
二. 你可以修改本开源软件的一个或几个副本或程序的任何部分，以此形成基于程序的作品。只要你同时满足
下面的所有条件，你就可以按前面第一款的要求复制和发布这一经过修改的程序或作品。
1.你必须在修改的文件中附有明确的说明: 你修改了这一文件及具体的修改日期。
2.你必须使你发布或出版的作品（它包含程序的全部或一部分，或包含由程序的全部或部分衍生的作品）允许
第三方作为整体按许可证条款免费使用。
3.如果修改的程序在运行时以交互方式读取命令，你必须使它在开始进入常规的交互使用方式时打印或显示声
明: 包括适当的版权声明和没有担保的声明（或者你提供担保的声明）；用户可以按此许可证条款重新发布
程序的说明；并告诉用户如何看到这一许可证的副本。（例外的情况: 如果原始程序以交互方式工作，它并
不打印这样的声明，你的基于程序的作品也就不用打印声明。
三. 只要你遵循一、二条款规定，您就可以自由使用并传播本源代码，但必须原封不动地保留原作者信息。|;
;;ssPts: 1 选择集，返回图元列表
;; 2 点表(1到n维 1维时key只能是x或X)，返回点表
;; 3 图元列表，返回图元列表
;;Key: "xyzXYZ"任意组合,例如"yX",y在前表示y坐标优先，小y表示从小到大(注:二维点时，不能有z)
;;FUZZ: 允许误差
;;注:点表可以1到n维混合,Key长度不大于点的最小维数。
;;示例1 (HH:ssPts:Sort (ssget) "YxZ" 0.5);返回(<Entity name: 7ef7b3a8> <Entity name: 7ef7b3a0>)
;;示例2 (HH:ssPts:Sort (list '(2 3) '(3 5)) "Yx" 0.5);返回((3 5) (2 3))
;;示例3 (HH:ssPts:Sort '(<Entity name: 7ef79a28> <Entity name: 7ef79a10>) "YxZ" 0.5)
;;示例4 (HH:ssPts:Sort (list "DF" "ZX" "A" "DD" "A") "X" 1)=>("ZX" "DF" "DD" "A" "A")
;;示例5 (HH:ssPts:Sort (list 5 8 5 9) "X" 1)=>(9 8 5)
;;本程序是在fsxm的扩展 自贡黄明儒 2014年3月22日
(defun HH:ssPts:Sort (ssPts KEY FUZZ / E EN FUN LST N)
;;1 点列表排序
(defun sortpts (PTS FUN xyz FUZZ)
(vl-sort pts
'(lambda (a b)
(if (not (equal (xyz a) (xyz b) fuzz))
(fun (xyz a) (xyz b))
)
)
)
)
;;2 排序
(defun sortpts1 (PTS KEY FUZZ)
(setq Key (vl-string->list Key))
(foreach xyz (reverse Key)
(cond ((< xyz 100)
(setq fun >)
(setq xyz (nth (- xyz 88) (list car cadr caddr)))
)
(T
(setq fun <)
(setq xyz (nth (- xyz 120) (list car cadr caddr)))
)
)
(setq Pts (sortpts Pts fun xyz fuzz))
)
)
;;3 本程序主程序
(cond
((= (type ssPts) 'PICKSET)
(repeat (setq n (sslength ssPts))
(if (and (setq e (ssname ssPts (setq n (1- n))))
(setq en (entget e))
)
(setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))
)
)
(mapcar 'last (sortpts1 lst KEY FUZZ))
)
((Listp ssPts)
(cond
((vl-consp (car ssPts)) (sortpts1 ssPts KEY FUZZ))
((= (type (car ssPts)) 'ENAME)
(foreach e ssPts
(if (setq en (entget e))
(setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))
)
)
(mapcar 'last (sortpts1 lst KEY FUZZ))
)
(T
(cond ((equal key "X") (vl-sort ssPts '>))
(T (vl-sort ssPts '<))
)
)
)
)
)
)
(defun lm-str-buwei(str a /)
(setq len(strlen str))
(while (< len a)
(setq str(strcat "0" str))
(setq len(strlen str))
)
str
)
;; 获取前缀函数：从字符串中提取前缀
(defun get-prefix (str)
(if (and
(setq idx (vl-string-search "-" str))
(> idx 0)
)
(substr str 1 (1+ idx));; 不包含 '-' 在前缀中
nil
)
)
;; 提示用户选择一个文本对象
(if (setq obj (car (entsel "\n请选择一个文本对象: ")))
(progn
;; 获取选定对象的前缀
(setq prefix (get-prefix (cdr (assoc 1 (entget obj)))))
(if prefix
(progn
;; 获取所有包含相同前缀的文本对象
(setq ss (ssget "X" (list (cons 0 "TEXT,MTEXT") (cons 1 (strcat prefix "*")))))
(if ss
(progn
;; 对对象进行排序
(setq tylst (HH:ssPts:Sort ss "Yx" 0.1))
;; 重新编号
(setq cnt 1)
(foreach ty tylst
(setq newText (strcat prefix (lm-str-buwei (itoa cnt) 2)))
(entmod (subst (cons 1 newText) (assoc 1 (entget ty)) (entget ty)))
(entupd obj)
(setq cnt (1+ cnt))
)
(princ "\n重新编号完成.")
)
(princ "\n没有找到匹配的文本对象.")
)
)
(princ "\n选定的对象没有有效的前缀.")
)
)
)
(princ)
)
(princ "\n加载完成。请输入 RenumberText 运行程序。")
(princ) 本帖最后由 你有种再说一遍 于 2024-5-28 17:14 编辑
lisp语料库最少了,肯定比其他拉一点.
其实你想用AI,那直接玩.net才是最好的,微软肯定会调整自己家c#的.
第二个问题,你问了一个二维排序问题,这个二维排序lisp确实难写.
pts.OrderBy(pt=>x).TherBy(pt=>y)
在c#这一句可以写lisp很多行...
然后你日后换表达式呢?
下上分行行左起,行右起,上下分行...
ld80721 发表于 2024-5-29 01:00
错误: 输入的列表有缺陷, 加载出现这个错误提示，请指点一下谢谢
1 直接用编辑器另存2 复制来的代码保存时 编码格式选ANSI 3现文件另存 选ANSI编码 飞雪神光 发表于 2024-5-28 01:12
有用，从左到右，从上到下的顺序，如果有对话框可选顺就更好。 属性块能不能实现这样的效果？ 蓦然语嫣 发表于 2024-5-28 06:47
有用，从左到右，从上到下的顺序，如果有对话框可选顺就更好。
就一个数据没必要搞对话框 飞雪神光 发表于 2024-5-28 01:12
错误: 输入的列表有缺陷, 加载出现这个错误提示，请指点一下谢谢;P 厉害了，学习一下 蓦然语嫣 发表于 2024-5-28 06:47
有用，从左到右，从上到下的顺序，如果有对话框可选顺就更好。
我是2007版本CAD，加载还是错误
页:
[1]
2