图框排版源码求优化！！
本帖最后由 依然小小鸟 于 2018-1-26 09:05 编辑封闭多段线横向排列
(defun c:ZKPB (/ os1 ss ss1 len1 len2 len3 eh-layer ename1 ename2 startpoint pbjj1 ename-list pt-list x-list y-list xminpt xmaxpt)
(vl-load-com)
(setvar "CMDECHO" 0)
(command "UNDO" "be")
(setq os1 (getvar "osmode"))
(setvar "osmode" 0)
;;-------------------------------------------------------------------
;;获得外框图层
(princ "\n选择一个对象以指定外框图层：")
(setq ss1 (ssget '((0 . "LWPOLYLINE"))))
(if (= ss1 nil)
(progn
(alert "未指定外框图层！")
(quit)
);progn
(progn
(setq len3 (sslength ss1))
(setq ename1 (ssname ss1 (1- len3)));取得外框图元名，如果是多选则返回最后一个选择对象的图元名
(setq eh-layer (eh-getDXF ename1 8));取得图层名称
(princ "选定的外框图层为：")(princ eh-layer)(princ "\n")
);progn
);if
;;-------------------------------------------------------------------
;;选取要排版的对象,实质是只选外框以进行分析
(princ "\n选择要排版的所有对象：")
(setq ss (ssget (list '(0 . "LWPOLYLINE") (cons 8 eh-layer))));根据指定外框的图层选择所有外框对象
(if (= ss nil)
(progn
(alert "未选择要排版的对象！")
(quit)
);progn
);progn
;---------------------------------------------------------------
;;指定排版间距
(if (= pbjj0 nil);pbjj0=默认排版间距，设为全局变量
(setq pbjj0 (float 100))
);if
(princ "\n请输入排版间距或直接量取<")(princ pbjj0)(princ ">:") ;;显示当前默认排版间距
;(initget "64")
(setq pbjj1 (getdist)) ;;获取排版间距
(if (= pbjj1 nil)
(setq pbjj1 pbjj0)
(setq pbjj0 pbjj1)
);if
;;-------------------------------------------------------------------
;;指定排版新起点
(setq startpoint (GetPoint "\n指定一点做为排版的新起点位置："))
(if (= startpoint nil)
(progn
(alert "未指定排版起点！")
(quit)
);progn
(progn (princ "\n新的起点坐标为：")(princ startpoint))
);if
;;-------------------------------------------------------------------
;;外框按X方向排序，取顶点表，执行移动
(if (= ss nil)
(progn
(alert "因未选择对象--而强制退出此排版程序！")
(quit)
);progn
(progn ;如果ss不为空，则执行下面的代码
(setq ename-list (eh-ss-sort ss));取得选择集的图元名并按X方向排序后重新排列图元名
(setq len1 (length ename-list));取得图元名列表的长度
(setq len2 0)
(while (< len2 len1)
(setq ename2 (nth len2 ename-list));按顺序取得外框的图元名
(setq pt-list (eh-getDXF ename2 10));取得多段线顶点列表
(setq x-list (mapcar 'car pt-list));取得所有点的X值
(setq y-list (mapcar 'cadr pt-list));取得所有点的Y值
(setq x-list (vl-sort x-list '<));X从小到大排序
(setq y-list (vl-sort y-list '<));Y从小到大排序
(setq xminpt (list (car x-list) (car y-list)))
(princ "\新对象基点x:")
(setq xmaxpt (list (last x-list) (car y-list)))
(eh-move pt-list xminpt startpoint);将坐标点代入移动函数，参数为CP选择方式点表，移动基点，目标点
(setq startpoint (cons (+ (car startpoint) (distance xminpt xmaxpt) pbjj1) (cdr startpoint)))
(princ "\n\n新的目标点坐标为：")(princ startpoint)
(setq len2 (1+ len2))
);while
);progn
);if
(command "UNDO" "e")
(setvar "cmdecho" 1)
(setvar "osmode" os1)
(princ)
);test
;;-----------------------------------------------------------------------------------------------------------
;;选择集图元名排序，按X方向升序排列，返回值为图元名升序列表
(defun eh-ss-sort (ss / len4 len5 ename ename1 ename-list ename-list1 x-minpt x-minpt-list pt-list x-list xx-list xx1 xx2 xx3)
(setq len4 (sslength ss));取得选择集的长度
(setq len5 0)
(setq ename-list '());设图元名表单初始值为空表
(setq x-minpt-list '())
;;;
(while (< len5 len4)
(setq ename (ssname ss len5));按顺序取得外框的图元名
(setq ename-list (cons ename ename-list));将所有图元名组合成表单
(setq pt-list (eh-getDXF ename 10));取得多段线顶点列表
;(princ pt-list)(princ "\n")
(setq x-list (mapcar 'car pt-list));取得所有点的X值
(setq x-list (vl-sort x-list '<));X从小到大排序
(setq x-minpt (car x-list));取最小X点值
(setq x-minpt-list (cons x-minpt x-minpt-list));将所有X点值组合成表单
(setq len5 (1+ len5))
)
(setq ename-list (reverse ename-list));图元名列表的表内元素倒置
(setq x-minpt-list (reverse x-minpt-list));X点表值的表内元素倒置
(setq xx-list (vl-sort-i x-minpt-list '<));取得点排序的索引号
;(princ x-minpt-list)(princ "\n")
;(princ ename-list)(princ "\n")
;(princ xx-list)(princ "\n")
;;根据索引号对图元名列表重新排序
(setq xx1 (length xx-list)
xx2 0
ename-list1 '()
);setq
(while (< xx2 xx1)
(setq xx3 (nth xx2 xx-list))
(setq ename1 (nth xx3 ename-list))
(setq ename-list1 (cons ename1 ename-list1))
(setq xx2 (1+ xx2))
);while
(setq ename-list1 (reverse ename-list1))
);defun
;;------------------------------------------------------------------------------------------------------------
;根据图元名取得指定的dxf组码值组成的表
;用法：(eh-getdxf 图元名 dxf组码/组码表)
;示例1：(eh-getdxf (ename) 8) 如果是单项返回字符串，多项返回表
;用例2: (eh-getdxf (ename) '(8 10 100)) 返回表
(defun eh-getDXF (ename codelst / entlst ehassoc)
(setq entlst (entget ename));根据图元名取得对象的所有dxf组码的信息表。
(setq ehassoc (function (lambda (lst key / l)
(setq l (vl-remove-if-not '(lambda (x) (= (car x) key)) lst))
(if (= (length l) 1)
(cdar l)
(mapcar 'cdr l)
);if
);lambda
);function
);setq
(if (listp codelst)
(mapcar (function (lambda (x) (apply ehassoc (list entlst x)))) codelst)
(apply ehassoc (list entlst codelst))
);if
);defun eh-getDXF
;;------------------------------------------------------------------------------------------------------------
;;以CP方式选择实体并移动
(defun eh-move (cp-ptlist pt1 pt2 / enameX);参数为CP选择方式点表，移动基点，目标点
(setq enameX (ssget "_CP" cp-ptlist))
(command "copy" enameX "" pt1 pt2)
(princ "\n执行copy时的基点和目标点:")
(princ pt1)(princ pt2)
;(vl-cmdf "move" enameX "" pt1 pt2)
(princ)
)
-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
有四点需要求助1. 如何只识别最外侧封闭多边形（图框有两个封闭多边形）2.怎么让图框Y方向上面也能排列 ，或者先X排列后Y排列或者增加一个选项 3. 怎么让图框以下面对齐而不是上面 4 由于图框大小不一样 有A2的有A3的，所以封闭多边形的大小也不一样如何让图框排版 以封闭多边形右下角的点为基准 所有图框与图框之间的距离 都一样这样我就可以批量插入图签和图号了 （通过贱人工具箱的递增复制和多重复制功能 ）因为 不管图框多大图签距离封闭多边形右下角的点的距离是恒定的所以以右下角的基准很重要
------------------------------------------------------------------------------------------------------------------------------------------------------------------------------感谢留言的各位我新增了 3 和 4 两点要求 一直没解决有大神能帮忙看看吗 ？
不知道悬赏明经币在哪里我这想悬赏一下
以前编过一个过滤掉矩形内矩形的子函数，给你整合一下
(defun c:qq (/ ent i j lst1 lst2 maxpoint minpoint name name1 name2 os1 panban1 pbjj1 pmax pmin pt1x pt1y pt2x pt2y pt3x
pt3y pt4x pt4y ptn ss )
(defun juxingguolv (ss / ent i j lst1 lst2 maxpoint minpoint name name1 name2 pmax pmin pt1x pt1y pt2x pt2y pt3x pt3y
pt4x pt4y ) ; 过滤掉矩形选择集内的矩形子函数
(setq lst1 '())
(repeat (setq i (sslength ss))
(setq name (ssname ss (setq i (1- i))))
(vla-getboundingbox (vlax-ename->vla-object name) 'minpoint 'maxpoint)
(setq pmax (vlax-safearray->list maxpoint)pmin (vlax-safearray->list minpoint))
(setq lst1 (cons (list pmin pmax name) lst1))
)
(setq lst2 lst1)
(repeat (setq i (length lst1))
(setq name (nth (setq i (1- i)) lst1))
(setq pt1x (car (car name))pt1y (cadr (car name))pt2x (car (cadr name))
pt2y (cadr (cadr name))name1 (caddr name) )
(repeat (setq j (length lst2))
(setq ent (nth (setq j (1- j))lst2 ))
(setq pt3x (car (car ent))pt3y (cadr (car ent)) pt4x (car (cadr ent))
pt4y (cadr (cadr ent)) name2 (caddr ent))
(if (and (> pt3x pt1x) (> pt3y pt1y)(< pt4x pt2x) (< pt4y pt2y))
(if (ssmemb name2 ss)(setq ss (ssdel name2 ss))))
(if (and (< pt3x pt1x) (< pt3y pt1y) (> pt4x pt2x)(> pt4y pt2y))
(if (ssmemb name1 ss) (setq ss (ssdel name1 ss))))))
ss
)
(vl-load-com)
(command "UNDO" "be")
(setq os1 (getvar "osmode"))
(setvar "osmode" 0)
(setvar "CMDECHO" 0)
(setvar "nomutt" 1)
(princ "\n选择一个对象以指定外框图层：")
(if (setq ss (ssget ":S" (list '(0 . "LWPOLYLINE") '(90 . 4))))
(progn
(setq ent (entget (ssname ss 0)))
(princ (strcat "\n外框图层" (cdr (assoc 8 ent))))
(princ ",选择要排版的所有对象：")
(if (setq ss (ssget (list '(0 . "LWPOLYLINE") '(90 . 4) (assoc 8 ent))))
(progn
(setvar "nomutt" 0)
(setq ss (juxingguolv ss))
(or pbjj (setq pbjj 100.0))
(or paiban (setq paiban "X") )
(if (setq pbjj1 (getdist (strcat "\n请输入排版间距或直接量取：<" (rtos pbjj 2 2) ">:")))
(setq pbjj pbjj1))
(if (member (setq panban1 (strcase (getstring (strcat "\n选择排版方向[横向(X)/纵向(Y)]：<" paiban ">")))) '("X" "Y"))
(setq paiban panban1))
(if (setq ptn (getpoint "\n指定一点做为排版的新起点位置："))
(progn
(repeat (setq i (sslength ss))
(setq name (ssname ss (setq i (1- i))))
(vla-getboundingbox (vlax-ename->vla-object name) 'minpoint 'maxpoint)
(setq pmax (vlax-safearray->list maxpoint) pmin (vlax-safearray->list minpoint))
(command "copy" (ssget "_c" pmin pmax) "" pmin ptn)
(cond
((= paiban "X") (setq ptn (list (+ (car ptn) (- (car pmax) (car pmin)) pbjj) (cadr ptn))))
((= paiban "Y") (setq ptn (list (car ptn) (+ (cadr ptn) (- (cadr pmax) (cadr pmin)) pbjj)))))))))))
)
(setvar "nomutt" 0)
(command "UNDO" "e")
(setvar "cmdecho" 1)
(setvar "osmode" os1)
(princ)
)
水吉空 发表于 2018-1-10 09:47
又想要别人义务劳动了。明经币也不悬赏几个。大神都给源码给你整合了。还要别人全部写好送到你面前才会用。 ...
其实我不太懂lisp我也没有明经币到时候可以发红包哈主要是我现在增加了两点新的想法帖子我重新编辑了一下 w245272914 发表于 2018-1-11 09:27
顶下，这程序我也很需要。狼大帅作品，有些部份会出问题，可能跟环境设置有问题
我现在增加了一些新的需求 因为我的图框大小经常不一样我图框排版的主要目的还是想批量插入图签和改图号 ，图框大小不一样后 图签与图签的距离也不一样了 (if (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "0") (90 . 4) (70 . 1) (43 . 0.0))))
(sssetfirst nil ss)
) 求大神指导啊 xyp1964 发表于 2018-1-4 21:55
(if (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "0") (90 . 4) (70 . 1) (43 . 0.0))))
(sssetfirst...
厉害了。{:1_1:}{:1_1:}{:1_1:}{:1_1:} langjs 发表于 2018-1-6 17:30
以前编过一个过滤掉矩形内矩形的子函数，给你整合一下
(defun c:qq (/ ent i j lst1 lst2 maxpoint minp ...
好像顺序有点不对，按y方向的不是从上到下，顺序有乱
偶然的遇到吗？？
请教，怎么修改为图框下端在一条水平线上？