cad批量页码lisp_源代码:批量改页码(加前缀)及提取属性块
本帖最后由 LLXXZZ 于 2011-9-4 14:58 编辑
在这个网页中
http://bbs.mjtd.com/thread-64566-1-1.html
有哥们确实向我要了源码,可能有些兄弟确实想看代码.现在给贴出来.
代码一般.没什么大不了的.但也着实让不少同仁受益.
页码的排序的功能写的不好,有优化的空间,懒得改了.哥们儿根据自己的需要自己改.
[code="lisp]
;提取属性块标记TagString或对应的值TextString
;ent:图元名,opt:为T程序返回TextString的表,为nil返回标记TagString的表
(defun xz-att-g (ent opt / liST0 liSTt liSTg blkref a)
(vl-load-com)
(if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object ent))) "AcDbBlockReference")
(if (vla-Get-HasAttributes blkref)
(progn (setq liST0 (vlax-safearray->list (vlax-variant-value (vla-GetAttributes blkref))))
(setq liSTt (mapcar 'vla-Get-TagString liST0))
(setq liSTg (mapcar 'vla-get-TextString liST0))
)
); endif
); endif
(if opt (setq a liSTg) (setq a liSTt))
a
); enddefun
;(setq ent (car (entsel))) 例子
;(xz-att-g ent t) (xz-att-g ent nil)例子
;******************************************************************************
;******************************************************************************
;******************************************************************************
(defun c:gat (/ EP1 blkname liSTt GETK ss index0 sslist tmp-pt sslist-ptl XZ_sortlist strlist
strlenlist0 nthx nthn strlenlist myentmk_line myentmk_text OSM BPM pt m)
(vl-load-com)
(while (not (setq EP1 (entsel"点取带属性的块:\n"))))
(if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object (car EP1)))) "AcDbBlockReference")
(if (vla-Get-HasAttributes blkref)
(progn
(setq blkname (assoc 2 (entget (car EP1))))
(setq liSTt (xz-att-g (car EP1) nil))
(princ (strcat" 属性块 块名为--> " (cdr blkname) "\n"))
)
)
(progn(princ " 必须选择属性块!")(exit))
)
;开始选择页码块并修改
(initget "H V S ")(setq GETK (getkword "排序方式:\n [横向优先(H)/竖向优先(V)/选择优先(S)]: "))
(princ ">>选择对象...")
(setq ss (ssget (cons blkname slist)))
(setq index0 0 index (sslength ss) sslist '())
(repeat index
(setq sslist (cons (ssname ss index0) sslist))
(setq index0 (1+ index0))
)
;开始构建图元点位表
(setq index0 0 sslist-ptl '() tmp-pt '())
(repeat index
(setq tmp-pt (cons (nth index0 sslist) (cons (cdr(assoc 10 (entget (nth index0 sslist)))) tmp-pt)))
(setq sslist-ptl (cons tmp-pt sslist-ptl))
(setq tmp-pt '())
(setq index0 (1+ index0))
)
;开始排序
(cond
;从左到右从上到下
((or (= GETK "H")(= GETK nil))
(setq XZ_sortlist (vl-sort
(vl-sort sslist-ptl '(lambda (s1 s2) (> (cadadr s1) (cadadr s2))))
'(lambda (s3 s4) (if(equal (cadadr s3) (cadadr s4) 0.6)(< (caadr s3) (caadr s4))))))
)
;从上到下从左到右
((= GETK "V")
(setq XZ_sortlist (vl-sort
(vl-sort sslist-ptl '(lambda (s1 s2) (< (caadr s1) (caadr s2))))
'(lambda (s3 s4) (if(equal (caadr s3) (caadr s4) 0.6)(> (cadadr s3) (cadadr s4))))))
)
;选择顺序
((= GETK "S")
(setq XZ_sortlist sslist-ptl))
);cond
;计算表内每列字符最长长度存储在表strlenlist中
(setq strlist (mapcar '(lambda (x) (xz-att-g (car x) t)) XZ_sortlist))
(setq strlenlist0 (mapcar '(lambda (x) (mapcar 'strlen x)) strlist))
(setq nthx 0 nthn (length (car strlenlist0)))
(setq strlenlist nil)
(while (< nthx nthn)
(setq nth1 (vl-sort strlenlist0 '(lambda (s1 s2) (>= (nth nthx s1) (nth nthx s2)))))
(setq strlenlist (cons (nth nthx (car nth1)) strlenlist))
(setq nthx (1+ nthx))
)
(setq strlenlist (reverse strlenlist))
;____________________________
;生成图元子程序
(defun myentmk_line (pt1 pt2 );(起点(uCS) 终点(uCS) 图层 颜色)
(command "_.line" pt1 pt2 "")
)
;(myentmk_line (getpoint)(getpoint))
(defun myentmk_text (cont pt1);(内容 起点)
(if (not (= "" cont)) (command "_.text" "J" "ml" pt1 3.0 0.0 cont ));对齐点为左中
)
;(myentmk_text " " (getpoint))
;____________________________
;提取初始状态
(setvar "CMDECHO" 0)
(setq OSM (Getvar "OSMODE" ))
(setq BPM (Getvar "blipmode"))
(setvar "OSMODE" 0)
(setvar "blipmode" 0)
;判断文字样式
(command "_.undo" "group")
;(if (tblsearch "style" "JHZX")
;(setvar "TEXTSTYLE" "JHZX")
;(command "-STYLE" "JHZX" "ros.shx,hztxt.shx" 0 0.75 0 "n" "n" "n" )
(command "-STYLE" "JHZX" "ros.shx,hztxt.shx" 0 0.75 0 "n" "n" "n" )
;) ;设置字体样式JHZX为当前样式
;_____________________________________________
;绘制表格子程序
(defun drawtable (lis row pt / x0 yo len x1 n pta ptb)
(setq x0 (car pt) yo (cadr pt) len (length lis))
(setq charlen (apply '+ lis))
;画横线
(setq x1 (+(* 1.5 charlen) (car pt) (* 20 len)))
(setq n 0)
(repeat (+ row 2)
(setq pta (list x0 (- yo (* n 4))) ptb (list x1 (- yo (* n 4))))
(myentmk_line pta ptb)
(setq n (1+ n))
)
;画竖线
(myentmk_line pt (polar pt (* 1.5 pi) (* (1+ row) 4)));第一根竖线
(setq n 0 x1 x0)
(while (< n len)
(setq x1 (+(* 1.5 (nth n lis)) 20 x1));第二根的x坐标n=0
(setq pta (list x1 yo) ptb (polar pta (* 1.5 pi) (* (1+ row) 4)))
(myentmk_line pta ptb)
(setq n (1+ n))
)
)
;_____________________________________________
;_____________________________________________
;绘制文字子程序
(defun drawtext (strlist strlenlist pt / x0 x1 pta n )
;pt第一个字的起点左中对齐,strlenlist字符长度表
(setq x0 (car pt) yo (cadr pt) len (length strlenlist))
;按横向写字
(myentmk_text (nth 0 strlist) pt);第一个文字
(setq n 0 x1 x0)
(while (< n len)
(setq x1 (+(* 1.5 (nth n strlenlist)) 20 x1));第二个文字的x坐标n=0
(setq pta (list x1 yo) )
(myentmk_text (nth (1+ n) strlist) pta)
(setq n (1+ n))
)
)
;_____________________________________________
;开始绘制表格
(setvar "OSMODE" OSM)
(while (not(setq pt (getpoint "指定表格的左上点:"))))
(if pt (setvar "OSMODE" 0))
(drawtable strlenlist index pt)
;表格中写上文字
(drawtext liSTt strlenlist (list (+ 10 (car pt)) (- (cadr pt) 2)));第一排为属性标记
(setq m 0)
(repeat (length strlist)
(setq pta (list (+ 10 (car pt)) (- (cadr pt) (* m 4) 6)))
(drawtext (nth m strlist) strlenlist pta)
(setq m (1+ m))
)
(command "_.undo" "end")
;还原初始状态
(setvar "OSMODE" OSM)
(setvar "blipmode" BPM)
(prin1)
)
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(defun c:gatinf ()
(alert " 欢迎使用本程序\n
1.此程序以送别同仁肖俊,今日他离职了,此处留个记号以标记今天的这个特别的日子。\n
2.同时提醒自己: 一日不读则愚!\n
3.程序调用了cad的line与text命令,所以程序反应比较慢,主要是自己对enmake函数应用不精,
抓紧时间学习这个函数。使用此函数将提高程序运行速度!\n
---by 李晓卓 2011.3.14
---RTX:60315
")(prin1)
)
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(princ "\n************************************************")
(princ "\n** 块属性提取 gat.lsp已加载 **")
(princ "\n** >>提取块属性,以gat启动命令 **")
(princ "\n** >>查看程序信息,以gatinf启动命令 **")
(princ "\n** ----by 李晓卓 **")
(princ "\n** 2011.3.14 **")
(princ "\n************************************************")
(princ)[/code][code="lisp]
;更改属性块标记tag所对应的值string
(defun xz-att (ent tag string / liST0 liST1 num blkref)
(vl-load-com)
(if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object ent))) "AcDbBlockReference")
(if (vla-Get-HasAttributes blkref)
(progn (setq liST0 (vlax-safearray->list (vlax-variant-value (vla-GetAttributes blkref))))
(setq liST1 (mapcar 'vla-Get-TagString liST0))
(setq num (vl-position tag list1))
(vla-put-TextString (nth num liST0) string)
)
); endif
); endif
(prin1)
); enddefun
;(setq ent (car (entsel))) 例子
;(xz-att ent "页码" 30) 例子
;*****************************************************************************
;排序方式
(defun xz-x (s0) (car (assoc 10 (entget s0)))) ;取出图元插入点的x坐标值
(defun xz-y (s0) (cadr (assoc 10 (entget s0)))) ;取出图元插入点的y坐标值
(defun xz-z (s0) (caddr (assoc 10 (entget s0)))) ;取出图元插入点的z坐标值
;从左到右,从上到下(reverse
;lst ----要排序的图元集 FUZZ----允许偏差;若无为nil
(defun xz-l2r (plist FUZZ / p1 p2)
(setq plist (vl-sort plist '(lambda (p1 p2)
;(cond
(cond((> (+(xz-y p1)FUZZ) (xz-y p2)) T))
(cond((and (= (+(xz-y p1)FUZZ) (xz-y p2)) (< (+(xz-x p1)FUZZ) (xz-x p2))) T))
;(cond((and (= (+(xz-x p1)FUZZ) (xz-x p2)) (= (+(xz-y p1)FUZZ) (xz-y p2))(> (+(xz-z p1)FUZZ) (xz-z p2))) T))
;(T nil)
;)
);lambda
)))
;从上到下,从左到右
;lst ----要排序的图元集 FUZZ----允许偏差;若无为nil (reverse
(defun xz-u2d (plist FUZZ / p1 p2)
(setq plist (vl-sort plist '(lambda (p1 p2)
(cond
((> (+(xz-x p1)FUZZ) (xz-x p2)) T)
((and (= (+(xz-x p1)FUZZ) (xz-x p2)) (> (+(xz-y p1)FUZZ) (xz-y p2))) T)
((and (= (+(xz-x p1)FUZZ) (xz-x p2)) (= (+(xz-y p1)FUZZ) (xz-y p2))(> (+(xz-z p1)FUZZ) (xz-z p2))) T)
(T nil)
)
);lambda
)))
;******************************************************************************
;******************************************************************************
;******************************************************************************
(defun c:pg (/ EP1 EG1 EG2 blktag EP1st blkname str GETK
index0 index sslist XZ_sortlist len0 len sslist-ptl index0)
(vl-load-com)
(if (progn
(setq EP1 (entsel"点取属性块中页码的位置:\n"))
(setq EG1 (cdr (assoc 0 (entget (car EP1)))))
(if (= EG1 "INSERT")
(progn (setq EG2 (car (nentselp (cadr EP1))))
(if (= (cdr (assoc 0 (entget EG2))) "ATTRIB")
(setq blktag (cdr (assoc 2 (entget EG2)))) ;标记
)
(setq EP1st (entget (car EP1)))
(setq blkname (assoc 2 EP1st))
)
)
)
(princ (strcat" 块名为-->" (cdr blkname) " 标记为-->" blktag "\n"))
(progn(princ " 必须选择属性块!")(exit))
)
;开始选择页码块并修改
(if (= str0 nil) (setq str0 1)) (initget 6)
(setq str (getint (strcat "请输入一个起始整数:")))
(if (= str nil)(setq str str0))
(initget "H V S ")(setq GETK (getkword "排序方式:\n [横向优先(H)/竖向优先(V)/选择优先(S)]: "))
(princ ">>选择批量修改页码的对象...")
(setq ss (ssget (cons blkname slist)))
(setq index0 0 index (sslength ss) sslist '())
(repeat index
(setq sslist (cons (ssname ss index0) sslist))
(setq index0 (1+ index0))
)
;开始构建图元点位表
(setq index0 0 sslist-ptl '() tmp-pt '())
(repeat index
(setq tmp-pt (cons (nth index0 sslist) (cons (cdr(assoc 10 (entget (nth index0 sslist)))) tmp-pt)))
(setq sslist-ptl (cons tmp-pt sslist-ptl))
(setq tmp-pt '())
(setq index0 (1+ index0))
)
;开始排序
(cond
;从左到右从上到下
((or (= GETK "H")(= GETK nil))
(setq XZ_sortlist (vl-sort
(vl-sort sslist-ptl '(lambda (s1 s2) (> (cadadr s1) (cadadr s2))))
'(lambda (s3 s4) (if(equal (cadadr s3) (cadadr s4) 0.6)(< (caadr s3) (caadr s4))))))
)
;从上到下从左到右
((= GETK "V")
(setq XZ_sortlist (vl-sort
(vl-sort sslist-ptl '(lambda (s1 s2) (< (caadr s1) (caadr s2))))
'(lambda (s3 s4) (if(equal (caadr s3) (caadr s4) 0.6)(> (cadadr s3) (cadadr s4))))))
)
;选择顺序
((= GETK "S")
(setq XZ_sortlist sslist-ptl))
);cond
;开始修改页码
(setq len0 0 len (length XZ_sortlist))
(repeat len
(if (setq ent0 (car (nth len0 XZ_sortlist)))
(progn (xz-att ent0 blktag str)
(princ (strcat "-->正在修改页码 "))
(setq len0 (1+ len0) str (1+ str))
(setq str0 str)
)
)
);repeat
(prin1)
)
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(defun c:pginf ()
(alert " 欢迎使用本程序\n
1.本程序为做越南万豪酒店施工图时所写.\n
2.本程序使用VisualLISP语言.\n
3.基于程序思想可以实现增加前缀及按页码打印,有空且心情好时再写.\n
4.本程序排序方法为属性块的插入点.\n
5.本程序通过ActiveX提取了属性块的标记而后修改相应的值.\n
6.程序已加密恕不提供源码.\n
7.如有疑问请自行保留.\n
---by 李晓卓 2010.9.11
---RTX:60315
")(prin1)
)
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(princ "\n************************************************")
(princ "\n** 批量改页码 pg.lsp已加载 **")
(princ "\n** >>批量改页码,以pg启动命令 **")
(princ "\n** >>查看程序信息,以pginf启动命令 **")
(princ "\n** ----by 李晓卓 **")
(princ "\n** 2010.9.11 **")
(princ "\n************************************************")
(princ)[/code]
cad批量页码lisp_源代码:批量改页码(加前缀)及提取属性块相关推荐
- Python 操作 pymysql 批量 增、删、改、查
github:https://github.com/PyMySQL/PyMySQL Python3 MySQL 数据库连接 - PyMySQL 驱动:Python3 MySQL 数据库连接 – PyM ...
- 批量修改图片名称且改为不同名字
批量修改图片名称且改为不同名字!这算是一种比较常见的批量修改文件名称的方式了,将文件名批量修改为不同的名称,所谓批量修改就是一次性修改大量文件名的意思,有别于传统的一个一个修改,批量修改文件名讲究的是 ...
- 计算机怎么快速改图片名称,如何批量修改文件名?批量修改照片文件名和添加前缀方法...
通常我们使用手机或者相机拍摄了一堆照片拷贝到电脑之后,照片的命名通常都是随机混乱的,如果要规范文件命名,你是不是会去一个一个去修改文件名呢?其实完全不需要这么麻烦,今天电脑百事小编就来教大家一个批量快 ...
- ArcGIS中批量导出Shp与批量转换CAD格式
ArcGIS中批量导出Shp与批量转换CAD格式 此博文包含图片 (2017-11-24 11:15:00)转载▼ 分类: ArcGIS ArcGIS批量导出shp图层中的某属性相同的图斑(一对多导出 ...
- CAD/CASS遮罩分图:带状图批量分幅,可依据闭合线批量分图,支持自定义图框,分图后可批量打印,可批量生成布局
插件下载:QTools for AutoCAD 功能位置:qq或qtools命令==>杂项==>遮罩分图(或直接ft命令) 功能介绍: 带状图批量分幅,可依据闭合线批量分图,支持自定义图框 ...
- 批量提取南方+纬地+鸿业断面数据,反推断面高程坐标、断面数据格式转换、批量绘制断面图、批量切断面 CAD/CASS断面插件合集(断面插件教程)
插件下载: QTools for AutoCAD 下载(APPLOAD命令加载,DM命令打开) 视频教程: QTools for AutoCAD的主页 - QTools官方账号 - 抖音 (douyi ...
- 电脑微博批量删除-2023怎么批量删除微博网页版代码
微博怎么快速批量删除_微博怎么把删除所有微博 你可以用它来批量删除微博.微博批量删除收藏和微博批量删除点赞内容,避免别人挖坟. 「2023批量删除微博工具」批量删除微博代码_手机暂时不能批量删除微博 ...
- 定量库存控制模型_经济订货批量不是最终的订货批量,计算订货批量的最高库存定量法...
上个星期,在我的供应链管理分享与交流群里,讨论订货批量时,有位朋友提到,采用经济订货批量订货时,按经济订货批量公式(详见下图,EOQ等于2乘以年总需求量乘以单次订货费用除以单位库存持有成本再开根号), ...
- visual studio 批量注释与取消批量注释快捷键
我改成了ctrl+/是注释,ctrl+'是取消注释,Qt用习惯了,比较方便. ------------------------------------ 用过一段时间的eclipse , 其非常便捷的批 ...
- 如何批量修改文件名?批量修改照片文件名和添加前缀
通常我们使用手机或者相机拍摄了一堆照片拷贝到电脑之后,照片的命名通常都是随机混乱的,如果要规范文件命名,你是不是会去一个一个去修改文件名呢?其实完全不需要这么麻烦,今天电脑百事小编就来教大家一个批量快 ...
最新文章
- 大数据、智慧城市成生态贵州新名片
- Hyperledger Fabric(术语表)
- 易语言mysql连接模块_易语言mysql链接模块libmySQL6.1模块源码
- 基于特征点匹配的自适应目标跟踪算法
- 检测工业级交换机性能好坏的8种方法
- C#开发微信门户及应用(32)--微信支付接入和API封装使用
- SpringCloud工作笔记73---Http协议操作工具集合
- 海量数据面试题----分而治之/hash映射 + hash统计 + 堆/快速/归并排序
- 【转载,留作参考】mysql 截取字符串以及mysql update select
- 《Maven_孔浩》Maven依赖
- QT_仿王者荣耀抽奖
- ecshop源码分析-ecshop二次开发
- bxp中好用的的文章(合适编程的人)(转)
- 人脸识别相机对人脸库进行增删改查——MQTT协议
- 【量化笔记】时间序列--ARCH模型及GARCH模型
- led灯条串联图_LED灯如何串联?
- 两数互素有什么性质_如何定义两个数互素的程度?
- valid/ready握手协议之ready打拍
- win7 host 中 vbox 虚拟机无法 attach USB device的问题
- 起航---开发基于国产华为鸿蒙操作系统的APP
热门文章
- 手机掌控汽车远程一键启动 预冷预热
- python手写计算器
- 如何加密PDF文件?多种实用方法介绍
- 学三菱plc编程应该先学什么?
- C语言学生成绩排名系统
- 随书光盘资源下载/提取码(二)
- Reg Organizer v8.75 注册表及系统清理优化工具
- Auslogics Registry Cleaner v9.2.0.0 注册表清理优化工具
- sqlserver 2012 MSSQLSERVER服务显示正在挂起更改且无法启动
- win7原版iso镜像下载 windows7官方原版全系列(正式版、专业版、企业版、家庭版)下载