各位大佬帮忙看看到底哪里有问题，编号总是从右到左
本帖最后由 wyy81061 于 2024-10-23 11:32 编辑各位大佬帮忙看看到底哪里有问题，我想要的图纸编号明明是从左到右，但是生成的却总是从右往左，到底哪里有问题？
(defun c:ERR (/ ss prefix start-num block-name attr tag cnt i block new-value block-list row-list)
;; 初始化变量
(setq cnt 0)
;; 块名称
(setq block-names '("YQFRAME_A3_0_TNNT" "YQFRAME_A3_0_TNNN")) ;; 块
;; 提示输入编号前缀
(setq prefix (getstring "\n请输入编号前缀: "))
;; 提示输入起始编号，默认值为 1
(setq start-num (getint "\n请输入起始编号编号 <1>: "))
(if (null start-num) (setq start-num 1)) ;; 如果为空，设置默认值为 1
;; 提示用户选择图框，只选择目标块
(setq ss (ssget '((0 . "INSERT") (2 . "YQFRAME_A3_0_TNNT,YQFRAME_A3_0_TNNN")))) ;; 选择指定块实例
;; 检查选择集是否存在
(if ss
(progn
;; 将选择的块按坐标放入列表
(setq block-list '())
(setq i 0) ;; 初始化索引
(while (< i (sslength ss))
(setq block (ssname ss i)) ;; 获取块
(setq block-name (cdr (assoc 2 (entget block)))) ;; 获取块定义名称
;; 调试输出：打印块名称
(princ (strcat "\n找到块: " block-name))
;; 判断是否为目标块
(if (member block-name block-names)
(progn
;; 获取块的插入点
(setq ins-point (cdr (assoc 10 (entget block)))) ;; 获取插入点
;; 将块和插入点添加到列表
(setq block-list (cons (list ins-point block) block-list))
)
)
(setq i (1+ i)) ;; 遍历下一块
)
;; 调试输出：打印找到的块数量
(princ (strcat "\n共找到 " (itoa (length block-list)) " 个目标块。"))
;; 按 y 坐标升序排序
(setq block-list (vl-sort block-list
(function (lambda (a b)
(< (cadr (car a)) (cadr (car b))) ;; 按 y 坐标升序
))
))
;; 按行分组块，并对每行内的块按 x 坐标升序排序
(setq row-list '())
(setq current-row nil)
(foreach blk block-list
(setq ins-point (car blk))
(setq block (cadr blk))
(setq y-value (cadr ins-point))
;; 检查当前行是否存在
(if (and current-row (= (cadr (car current-row)) y-value)) ;; 如果是同一行
(setq current-row (cons blk current-row)) ;; 将块添加到当前行
(progn
(if current-row ;; 如果当前行存在，保存到行列表
(setq row-list (cons (vl-sort current-row
(function (lambda (a b)
(< (car (car a)) (car (car b))) ;; 按 x 坐标升序
))
) row-list))) ;; 先对当前行内的块按 x 坐标升序排序并保存
(setq current-row (list blk)) ;; 开始新的行
)
)
)
;; 添加最后一行
(if current-row (setq row-list (cons (vl-sort current-row
(function (lambda (a b)
(< (car (car a)) (car (car b))) ;; 按 x 坐标升序
))
) row-list)))
;; 遍历每一行，更新图号属性
(foreach row row-list
(setq cnt-in-row 0)
;; 在此处对每一行内的块按 x 坐标升序排序
(foreach blk (vl-sort row
(function (lambda (a b)
(< (car (car a)) (car (car b))) ;; 按 x 坐标升序
))
) ;; 对每一行内的块按 x 坐标排序
(setq block (cadr blk)) ;; 获取块
;; 遍历块中的属性
(setq attr (entnext block))
(setq has-tag nil)
(while (and attr (/= (cdr (assoc 0 (entget attr))) "SEQEND"))
(if (= (cdr (assoc 0 (entget attr))) "ATTRIB") ;; 检查是否为属性
(progn
(setq tag (cdr (assoc 2 (entget attr)))) ;; 获取属性标签
;; 调试输出：打印当前属性标签
(princ (strcat "\n检查属性: " tag))
;; 检查是否为“图号”属性
(if (eq tag "图号")
(progn
;; 强制更新图号属性
(setq new-value (strcat prefix (itoa start-num))) ;; 生成新的编号
(entmod (subst (cons 1 new-value) (assoc 1 (entget attr)) (entget attr))) ;; 修改属性值
(entupd attr) ;; 更新块
(setq cnt (1+ cnt)) ;; 修改计数增加
(setq start-num (1+ start-num)) ;; 编号递增
(setq has-tag t) ;; 该行已经有图号
)
)
)
)
(setq attr (entnext attr)) ;; 获取下一个属性
)
;; 如果当前行没有图号，则为当前行的块编号
(if (not has-tag)
(progn
(setq new-value (strcat prefix (itoa start-num))) ;; 生成新的编号
(entmod (subst (cons 1 new-value) (assoc 1 (entget block)) (entget block))) ;; 修改属性值
(entupd block) ;; 更新块
(setq start-num (1+ start-num)) ;; 编号递增
(setq cnt (1+ cnt)) ;; 修改计数增加
)
)
)
)
;; 提示修改了多少个图框
(princ (strcat "\n共修改了 " (itoa cnt) " 个图框"))
)
(princ "\n未选择任何块.")
)
(princ)
)
(defun c:ERR (/ block-list block-names cnt hh:sspts:sort lm-get-attribute lm-set-attribute new-value prefix ss start-num)
;;********通用点表排序
;|本软件为开源软件: 以下是开源申明:
-----------------------------------------------------------------------------------------------;
本页面的软件遵照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-set-attribute(ty biaoji va / att_list)
(setq ty (if(=(type ty)'ename)(vlax-ename->vla-object ty)ty))
(setq att_list (vlax-safeArray->list (vlax-variant-value (vla-getattributes ty))))
(vla-put-textstring(vl-some'(lambda(a)(if(=(strcase(vla-get-TagString a))(strcase biaoji))a))att_list)va)
(princ)
)
(defun lm-get-attribute (ty sx / att_list)
(setq ty (if(=(type ty)'ename)(vlax-ename->vla-object ty)ty))
(setq att_list (vlax-safeArray->list (vlax-variant-value (vla-getattributes ty))))
(if (setq TagString (vl-some '(lambda (a) (if (= (strcase (vla-get-TagString a)) (strcase sx)) a)) att_list))
(vla-get-TextString TagString)
nil
)
)
(setq cnt 0)
(setq block-names '("YQFRAME_A3_0_TNNT" "YQFRAME_A3_0_TNNN" )) ;; 块
(setq prefix (getstring "\n请输入编号前缀: "))
(setq start-num (getint "\n请输入起始编号编号 <1>: "))
(if (null start-num) (setq start-num 1)) ;; 如果为空，设置默认值为 1
(setq ss (ssget '((0 . "INSERT")(66 . 1)))) ;; 选择指定块实例
(if ss
(progn
(princ (strcat "\n共找到 " (itoa (sslength ss)) " 个目标块。"))
(setq block-list (HH:ssPts:Sort ss "Yx" 5))
(foreach blk block-list
(setq block-name (cdr (assoc 2 (entget blk))))
(if (and
(lm-get-attribute blk "图号")
(member block-name block-names)
)
(progn
(setq new-value (strcat prefix (itoa start-num)))
(lm-set-attribute blk "图号" new-value)
(setq start-num (1+ start-num))
(setq cnt (1+ cnt))
)
)
)
(princ (strcat "\n共修改了 " (itoa cnt) " 个图框"))
)
(princ "\n未选择任何块.")
)
(princ)
)
这一段并没有成功按组分出两行的表 ;; 按行分组块，并对每行内的块按 x 坐标升序排序
(setq row-list '())
(setq current-row nil)
(foreach blk block-list
(setq ins-point (car blk))
(setq block (cadr blk))
(setq y-value (cadr ins-point))
;; 检查当前行是否存在
(if (and current-row (= (cadr (car current-row)) y-value)) ;; 如果是同一行
(setq current-row (cons blk current-row)) ;; 将块添加到当前行
(progn
(if current-row ;; 如果当前行存在，保存到行列表
(setq row-list (cons (vl-sort current-row
(function (lambda (a b)
(< (car (car a)) (car (car b))) ;; 按 x 坐标升序
))
) row-list))) ;; 先对当前行内的块按 x 坐标升序排序并保存
(setq current-row (list blk)) ;; 开始新的行
)
)
) 本帖最后由 wyy81061 于 2024-10-23 17:01 编辑
飞雪神光 发表于 2024-10-23 13:33
按你的代码确实可以实现，非常感谢
页:
[1]