常用函数.lsp
本帖最后由 自贡黄明儒 于 2022-5-16 13:53 编辑;;各位，把你们收藏都拿出秀一秀呀，放在箱底会生霉的
;;我的收集是在caoyin发布的通用函数基础上扩展的----自贡黄明儒 2012.9.20
;;有人说,抄一个人的叫偷,抄多个人的叫做研究,如果这种说话真的成立的话,那么我是在进行研究
;;1 [功能] 检查加载vlisp扩展
;;2常数(lisp编辑器在输出局部变量时,带*的会排在前面.Caoyin这样写很有道理)
;;3 [功能] 返回活动空间vla对象
;;4.1 [功能] 返回当前活动空间名称("Model" or "Paper")
;;4.2 [功能] 返回空间名称,如"Model"或者"Layout1"...
;;5 [功能] 返回Preferences vla对象
;;6 [功能] 返回指定引用的属性
;;7 [功能] 更改引用设置
;;8 [功能] 返回 acad对象的属性
;;9 [功能] 对象名称
;;10 [功能] 打开文件名列表
;;11 [功能] 查询对象属性和方法
;;12 [功能] 设置 Qleader 命令“引线设置”对话框的相关参数
;;13 [功能] 求点集中最远，最近点表 ;By 无痕
;;14.1 [功能] 返回指定集合的数量
;;14.2 [功能] 返回文档集合的数量
;;15 [功能] 返回文档指定对象的属性
;;15.1 [功能] 图层集合
;;15.2 [功能] 线型集合
;;15.3 [功能] 文字样式集合
;;15.4 [功能] 尺寸样式集合
;;15.5 [功能] 布局集合
;;15.6 [功能] 词典集合
;;15.7 [功能] 块集合
;;15.8 [功能] 打印配置集合
;;15.9 [功能] 视图集合
;;15.10 [功能] 视口集合
;;15.11 [功能] 组集合
;;15.12 [功能] 注册程序集合
;;16 [功能] 返回集合成员名称列表
;;16.1 [功能] 返回线型集合成员名称列表(常量*LTS*)
;;16.2 [功能] 返回层集合成员名称列表(常量*LAYS*)
;;16.3 [功能] 返回文字样式集合成员名称列表(常量*STS*)
;;16.4 [功能] 返回尺寸样式集合成员名称列表
;;16.5 [功能] 返回布局集合成员名称列表
;;16.6 [功能] 返回词典集合成员名称列表
;;16.7 [功能] 返回块集合成员名称列表
;;16.8 [功能] 返回打印配置集合成员名称列表
;;16.9 [功能] 返回视图集合成员名称列表
;;16.10 [功能] 返回视口集合成员名称列表(同常量*VPS*)
;;16.11 [功能] 返回组集合成员名称列表
;;16.12 [功能] 返回注册程序集合成员名称列表
;;17 [功能] 点表排序(根据x Y 或者Z坐标排序)
;;18 [功能] 集合->列表
;;19 [功能] 线型数量
;;20 [功能] 对集合对象的每个成员执行指定函数的操作
;;20.1 [功能] 显示集合对象每个成员的方法和属性.既然是集合,方法是相同的
;;20.2 [功能] 删除对象
;;21.1 [功能] ename->vla对象
;;21.2 [功能] vla对象->ename
;;22 [功能] 返回对象名称(见9)
;;23.1 编组开始(command "_.undo" "be")
;;23.2 编组结束(command "_.undo" "END")
;;24 [功能] 用一个对象的属性等修改另一个对象的属性
;;24.1 [功能] 用一个对象的'(图层 线型...)修改另一个对象的图层 线型...等
;;25.1 [功能] 配置文件集合
;;25.2 [功能] 设置配置文件
;;25.3 [功能] 重新装载配置文件
;;25.4 [功能] 重启默认配置文件
;;25.5 [功能] 输出配置文件
;;25.6 [功能] 输出配置文件
;;25.7 [功能] 输入配置文件
;;25.8 [功能] 复制配置文件
;;25.9 [功能] 重命名配置文件
;;25.10 [功能] 删除配置文件
;;25.11 [功能] 配置文件是否存在
;;25.12 [功能] 配置文件列表
;;26.1 [功能] 非当前文档,关闭(不保存)
;;27.1 [功能] 保存所有文档
;;27.2 [功能] 活动文档是否已经保存?
;;27.3 [功能] 另存为2K格式
;;27.4 [功能] 另存为R14格式
;;28.1 [功能] 清理打开文档
;;28.2 [功能] 删除未使用的图层,比purge彻底
;;29.1 [功能] 取得选定块的指定属性
;;29.2 [功能] 取得块属性列表
;;29.3 [功能] [功能] 取得块属性列表
;;29.4 [功能] Returns a list of constant attributes tags and their values
;;30.1 [功能] 更改块指定属性
;;30.2 [功能] 更改选定块的指定属性
;;30.3 [功能] 更改块多个属性
;;30.4 [功能] 更改块多个属性
;;31.1 [功能] 返回指定(块名 标记 属性值)的块 选择集
;;31.2 [功能] 返回指定(块名 标记 属性值)的块 选择集
;;32.1 [功能] 更改属性位置
;;32.2 [功能] 更改块属性宽度
;;32.3 [功能] 更改块属性高度
;;33 [功能] 列表块插入点(Y排序)
;;34 [功能] 块集的某一属性,显示块的x(or y z)值
;;35.1 [功能] 块中删除对象
;;35.2 [功能] 块增加对象
;;34 [功能] 返回指定块每一个引用实体名列表
;;35 [功能] 块引用名列表
;;36 [功能] 删除指定名的所有块
;;37 [功能] 块名"BTL"是否存在
;;38 [功能] 块更名
;;39 [功能] 块名例表
;;40 [功能] XRef图块列表
;;41 [功能] 返回名为"bn"的XRef图块实体列表
;;42 [功能] 返回包容点集的最小点最大点列表
;;43.1 [功能] 两点中点
;;43.2 [功能] <起点>,<中点>,<终点>列表;By 无痕
;;44 [功能] 求矩形中心
;;45 [功能] 返回封闭曲线质心二维坐标
;;46.1 [功能] 多段线各顶点(见99.3)
;;46.2 [功能] pline,lwpline点坐标表By 无痕
;;46.3 [功能] 返回包含每一出现在列表中的指定键的cdr(点对的后部分)的列表
;;47 [功能] 曲线是否封闭
;;48 [功能] 返回一个包涵经过pt点的多段线端点的列表
;;49 [功能] 把弧变成圆
;;50.1 [功能] 线型是否存在?
;;50.2 [功能] 改变vla对象线型
;;51.1 [功能] 角度->弧度
;;51.2 [功能] 弧度->角度
;;52.1 [功能] 3D点->2D点 By Caoyin
;;52.2 [功能] 3D点->2D点
;;52.3 [功能] 3D点列表->2D点列表
;;52.4 [功能] 3D点列表->2D点列表
;;52.5 [功能] 对表分段
;;53.1 [功能] 画线
;;53.2 [功能] 根据点表画线
;;54 [功能] 画弧
;;55 [功能] 画圆
;;56 [功能] 画多段线
;;56.1 [功能] 画椭圆
;;56.2 [功能] 画椭圆弧
;;56.3 [功能] 画椭圆弧
;;57 [功能] 生成一个点
;;58 [功能] 单行文字
;;59 [功能] 画多边形
;;60 [功能] 画矩形
;;61 [功能] 画长方体
;;62 [功能] 多行文字MText
;;63 [功能] 面域Region
;;64 [功能] 对象外画一矩形
;;65.1 [功能] 创建图层(成功返回层名)
;;65.2 [功能] 创建一个图层(新建层不为当前层)
;;66.1 [功能] 表->变体数组类型
;;66.2 [功能] 表->整数数组
;;66.3 [功能] 表->变体数组
;;66.4 [功能] 选择集->数组
;;66.5 [功能] 列表->变体数组
;;67 [功能] 对象端点列表
;;68 [功能] 更改Vla对象线型比例
;;69 [功能] 将图层集合中的第一个图层设置为当前层
;;70 [功能] 设置指定层为当前层
;;71.1图层列表 开
;;71.2 [功能] 图层列表 关
;;71.3 [功能] 图层列表 冻结
;;71.4 [功能] 图层列表 解冻
;;71.5 [功能] 图层列表 [打印/不打印]
;;71.6 [功能] 图层列表 锁
;;71.7 [功能] 图层列表 解锁
;;71.8 [功能] 锁定图层列表
;;71.9 [功能] 返回冻结图层列表
;;71.10 [功能] 返回关闭图层列表
;;71.11 [功能] 可打印图层列表
;;71.12 [功能] 非打印图层列表
;;71.13 [功能] 层是否冻结？
;;71.14 [功能] 解冻 解锁 开 所有图层
;;71.15 [功能] 恢复图层状态By coaying
;;71.16 [功能] 得到图层状态highflybird
;;71.17 [功能] 恢复图层状态highflybird
;;71.18 [功能] 图层是否锁定?
;;72 [功能] 设置vla对象线宽
;;73 [功能] vla选择集是否存在
;;74.1 [功能] 返回指定类型的选择集
;;74.2 [功能] 返回指定类型的选择集
;;74.3 [功能] 返回0层上的圆选择集
;;74.4 [功能] 返回圆选择集(并打印名称)
;;75.1 [功能] 返回CAD窗口状态
;;75.2 [功能] 设置CAD窗口状态
;;76.1 [功能] 隐藏CAD
;;76.2 [功能] 显示CAD
;;76.3 [功能] 隐藏CAD一段时间
;;77.1 [功能] CAD参数选择
;;77.2 [功能] 线宽显示
;;77.3 [功能] 隐藏线宽
;;77.4 [功能] 对象捕捉开
;;77.5 [功能] 对象捕捉关闭
;;77.6 [功能] 图形被其它用户参照时仍可以立即编辑
;;77.7 [功能] 图形被其它用户参照时不可以立即编辑
;;78.1 [功能] CAD菜单集合
;;78.2 [功能] 菜单列表
;;78.3 [功能] 菜单是否存在
;;78.4 [功能] 工具条Vla集合
;;78.5 [功能] 工具条列表
;;78.6 [功能] 工具条列表
;;78.7 [功能] 工具条是否存在
;;78.8 [功能] 指定工具条(Vla)
;;78.9 [功能] 显示指定工具条
;;78.10 [功能] 隐藏工具条
;;78.11 [功能] 工具条放置位置
;;78.12 [功能] Float a given toolbar at specified position(top and left)
;;78.13 [功能] 改变工具条按钮位图
;;79 [功能] 2D点转成vla 2D
;;80 [功能] 激活最左边一个布局
;;81 [功能] VLA选择集过滤条件
;;81 [功能] 类型库智能化加载
;;82 [功能] 转换路径中字符 "/" 为 "\\" 并返回大写值
;;83 [功能] 通过IE 显示一个 HTML 字符串
;;84.1 [功能] 显示时间/日期对话框
;;84.2 [功能] Returns the logical drive letter to which a network share is mapped
;;84.3 [功能] 返回驱动器类型
;;84.4 [功能] 返回驱动器列表
;;84.5 [功能] 修改本地磁盘的卷标
;;84.6 [功能] 执行 DOS DELTREE 命令
;;84.7 [功能] 创建目录
;;84.8 [功能] 复制文件或目录
;;84.9 [功能] 复制目录下所有文件和目录
;;84.10 [功能] 移动文件或目录
;;84.11 [功能] 重命名文件或目录
;;84.12 [功能] 返回磁盘的类型
;;84.13 [功能] 返回当前的磁盘表
;;84.14 [功能] 返回磁盘的所有信息
;;84.15 [功能] 返回文件的特定信息
;;84.16 [功能] 返回磁盤的所有信息
;;84.17 [功能] 读文本文件到表 (快于 AutoLISP read-line函数)
;;84.18 [功能] 将字符串或表写入文件 (快于 AutoLISP write-line函数)
;;84.19 [功能] 目录浏览对话框
;;84.20 [功能] 显示 windows 的确认对话框包括图标和可选按钮
;;84.21 [功能] 当前目录文件搜索. 类似于 DIR /S 命令
;;84.22 [功能] 合并两个文本文件
;;85.1 [功能] 字符串分割为表By 无痕
;;85.2 [功能] 字符串分割为表 -------梁雄啸.2004.3
;;85.3 [功能] 字符串分割为表 (纯autolspl的写法)-----梁雄啸.2004.3
;;85.4 [功能] 字符串分割为表
;;85.5 [功能] 字符串分割成表
;;85.6 [功能] 字符串函数 by qjchen@gmail.com
;;85.7 [功能] 用分隔符解释字符串成表 ;by fsxm
;;85.8 [功能] 字符串分割(这是highflybird问答我的求助)
;;86.1 [功能] Exports the specified project to disk
;;86.2 [功能] Imports a project exported by MJ:ExportProject
;;87.1 [功能] 包围对象最小最大点列表
;;87.2选择集的实体外矩形框 by gxl
;;88 [功能] 返回曲线长度(不能返回块中曲线长度)
;;89 [功能] Returns the size of the specified file in bytes
;;90.1 [功能] 返回文字样式字体高度
;;90.2 [功能] 设置文字样式字体高度
;;91 [功能] Returns the LISP value of an ActiveX variant
;;92.1 [功能] Attach Extended Entity Data to an AutoCAD object
;;92.2 [功能] Get Extended Entity Data attached to an AutoCAD object
;;93 [功能] 面积标注
;;94 [功能] 重命名布局
;;95 [功能] 返回打开文件列表
;;96 [功能] 返回布局列表
;;97 [功能] 窗口左下角空间切换是否显示
;;98.1 [功能] 模型空间背景色在空白之间切换
;;98.2 [功能] 布局空间背景色在空白之间切换
;;99.1 [功能] 表->二维表
;;99.2 [功能] 表->三维表
;;99.3 [功能] 获取多段线顶点列表(见46)
;;99.4 [功能] 两对象交点
;;100.1 [功能] 判断是否val对象?
;;100.2 [功能] 判断是否字符串
;;100.3 [功能] 判断是否实数?
;;100.4 [功能] 判断是否ename对象?
;;100.5 [功能] 判断是否变体?
;;100.6 [功能] 判断 X 是否是选择集且长度不为 0
;;101 [功能] 多段线顶点的连续样式产生线型
;;102.1 [功能] 使对象颜色随层
;;102.2 [功能] 设置当前颜色
;;103 [功能] 打印配置
;;104 [功能] 打印设备列表
;;105.1 [功能] 清除所有捕捉，与按F3有不同处(参见77.4)
;;105.2 [功能] MJ:SnapOn之后下面函数只启用端点捕捉
;;106 [功能] 打开一个文件
;;107.1 [功能] 原位复制Vla
;;107.2 [功能] 原位复制ename
;;107.3 [功能] 原位置复制VLA选集
;;107.4 [功能] 删除VLA选择集
;;107.5 [功能] 块内原地复制 By xshrimp
;;107.6 [功能] 块内原地复制 by highflybird
;;107.7 [功能] 块内原地复制 by GSLS(SS)
;;108 [功能] 输出 WMF SAT EPS DXF BMP格式文件
;;109 [功能] 移动Move
;;110 [功能] 偏移
;;111 [功能] 退出Acad
;;112 [功能] 重生成
;;113 [功能] 旋转
;;114.1 [功能] 多段线添加节点Vertex
;;114.2 [功能] 多段线修改节点Vertex
;;115 [功能] 文件名已经保存，返回T；新建一文件，未命名保存过，返回 nil
;;116.1 [功能] 缩放整个图形
;;116.2 [功能] 缩放到实际范围
;;116.3 [功能] pt中心点缩放1
;;116.4 [功能] pt中心点缩放2
;;116.5 [功能] 两点窗口缩放
;;116.6 [功能] 视口比例缩放-放大2倍
;;116.7 [功能] 视口比例缩放
;;116.8 [功能] 返回上一视图
;;117.1 [功能] 在当前视图状况下将图形单位转换为像素
;;117.2 [功能] 返回当前视窗左下角和右上角 坐标
;;117.3 [功能] pickbox大小
;;118 [功能] 获取 0~1 之间的随机数 (by zml84)
;;119.1 [功能] 将 ACI 索引颜色转换成 RGB 配色系统
;;119.2 [功能] 将 RGB 配色系统转换成 ACI 索引颜色
;;120.1 [功能] 选择集->图元列表
;;120.2 [功能] 选择集->图元列表 By caiqs
;;120.3 [功能] 图元列表->选择集
;;120.4 [功能] 图元列表->选择集 By caiqs
;;121 [功能] 根据当前文档的图形单位精度将实数转换为字符串
;;122.1 [功能] 遍历选择集对所包含的图元进行指定函数操作
;;122.2 [功能] 遍历选择集对所包含的图元进行指定函数操作
;;123 [功能] 获取当前 AutoCAD 的版本
;;124 [功能] 获取 DXF 组码值
;;125.1 [功能] 获取在图元 en 之后产生的图元列表
;;125.2 [功能] 获取在图元 en 之后产生的图元的选择集
;;126 [功能] 打印列表中的数据
;;127 [功能] 更新组码
;;128.1 [功能] 选择集->无名块
;;128.2 [功能] 用 [选择集/obj表] 做成一个块
;;128.3 [功能] 选择集做成一个块
;;129.1 [功能] 删除表中相同图元
;;129.2 [功能] 剔除表元素 By 无痕
;;130 [功能] 获得特定符号表的列表
;;131.1 [功能] 返回a在表lst中的位置 or nil
;;131.2 [功能] 从列表中删除指定的元素
;;132 [功能] 关键字a的列表框增加内容
;;133.1 [功能] 旋转一个点
;;133.2 [功能] 缩放一个点
;;134.1 [功能] 返回文件名(带扩展名) (反findfile)
;;134.2 [功能] 去文件名扩展,比如去掉.exe
;;134.3 [功能] 分割文件名为三部分
;;135 [功能] p1是否在p2 p3线上
;;136 [功能] 亮显选择集或对象(夹点不显示) 函数
;;137.1 [功能] 获得图形中倒数第二个图元的函数
;;137.2 [功能] 图中最后图元Find True last entity
;;138.1 [功能] 读取指定文件中指定行的内容
;;138.2 [功能] 返回文件行数量
;;138.3 [功能] 读取文件并按行将文件转换为表
;;139 [功能] 用 [选择集/obj表] 做成一个组
;;140 [功能] 加载幻灯片
;;141 [功能] 点表排序
;;142 [功能] 选择集相减 By 自贡黄明儒
;;143.1 [功能]选择集SS排序->图元列表 By 自贡黄明儒
;;143.2 [功能]选择集排序->选择集 By 自贡黄明儒
;;144.1 [功能] 读取系统剪贴板中字符串
;;144.2 [功能] 向系统剪贴板写入文字
;;145 [功能] 求多段线上的弧段(圆或圆弧也有效)的圆心
;;146 [功能] 质心
;;147.1 [功能] 自定义max By yjr111
;;147.2 [功能] 自定义max By G版
;;148.1 [功能] 根据点表画多段线
;;148.2 [功能] 根据点表画多段线
;;148.3 [功能] 根据点表画样条曲线
;;149.1 [功能] 进程显示
;;149.2 [功能] 进程显示
;;150 [功能] 生成无名组
;;151 [功能] 曲线选集长度求和--陌生人.2004.1
;;152 [功能] 局部更新
;;1 [功能] 检查加载vlisp扩展
(vl-Load-COM)
;;2常数(lisp编辑器在输出局部变量时,带*的会排在前面.Caoyin这样写很有道理)
(setq *En2Obj*vlax-ename->vla-object
*Obj2En*vlax-vla-object->ename
*2PI* (* PI 2)
*0.5PI* (/ PI 2)
*0.25PI*(/ PI 4)
;;常用VLA对象、集合
*ACAD*(vlax-get-acad-object)
*DOC* (vla-get-ActiveDocument *ACAD*)
*DOCS*(vla-get-Documents *ACAD*)
*MS* (vla-get-modelSpace *DOC*)
*PS* (vla-get-paperSpace *DOC*)
*BLKS*(vla-get-Blocks *DOC*)
*LAYS*(vla-get-Layers *DOC*)
*LTS* (vla-get-Linetypes *DOC*)
*STS* (vla-get-TextStyles *DOC*)
*GRPS*(vla-get-groups *DOC*)
*DIMS*(vla-get-DimStyles *DOC*)
*LOUTS* (vla-get-Layouts *DOC*)
*VPS* (vla-get-Viewports *DOC*)
*VS* (vla-get-Views *DOC*)
*DICS*(vla-get-Dictionaries *DOC*)
;;常用的几个外部接口对象
*FSO* (vlax-get-or-create-object "Scripting.FileSystemObject")
*WSH* (vlax-get-or-create-object "wscript.shell")
*SHELL* (vlax-get-or-create-object "Shell.Application")
*SCR* (vlax-get-or-create-object "ScriptControl")
*WBEM*(vlax-get-or-create-object "WbemScripting.SWbemLocator")
)
;;3 [功能] 返回活动空间vla对象
(defun MJ:ActiveSpace()
(if (= 1 (vlax-get-Property DOC* 'ActiveSpace));模型1,布局0
*MS*
*PS*
)
)
;;4.1 [功能] 返回当前活动空间名称("Model" or "Paper")
(defun MJ:ActiveSpace-Name ()
(if (= 1 (vla-get-ActiveSpace *DOC*))
"Model"
"Paper"
)
)
;;4.2 [功能] 返回空间名称,如"Model"或者"Layout1"...
(defun MJ:ActiveSpace1 ()
(vla-get-Name (vla-get-ActiveLayout *DOC*))
)
;;5 [功能] 返回Preferences vla对象
(defun MJ:AcadPrefs ()
(vlax-Get-Property *ACAD* 'Preferences)
)
;;6 [功能] 返回指定引用的属性
;;TabName:Application,Display,Drafting,Files,OpenSave,Output,Profiles,Selection,System,User
;; 示例 (MJ:GetPrefKey 'Files 'SupportPath)获取支持文件路径
(defun MJ:GetPrefKey (TabName KeyName)
(vlax-get-property
(vlax-get-property
(MJ:AcadPrefs)
TabName
)
KeyName
)
)
;;7 [功能] 更改引用设置
;; 示例 (MJ:SetPrefKey "OpenSave" "IncrementalSavePercent" 0)
(defun MJ:SetPrefKey (TabName KeyName NewVal)
(vlax-put-property
(vlax-get-property
(MJ:AcadPrefs)
TabName
)
KeyName
NewVal
)
)
;;8 [功能] 返回 acad对象的属性
;;PropName:ActiveDocument,Application,Caption,Documents,FullName,Height,HWND,LocaleId,MenuBar,
;;MenuGroups,Name,Path,Preferences,StatusId,VBE,Version,Visible,Width,WindowLeft,WindowState,WindowTop
;; 示例 (MJ:AcadProp 'FullName)
(defun MJ:AcadProp (PropName)
(vlax-get-property *ACAD* PropName)
)
;;9 [功能] 对象名称
;; 示例 (MJ:Name *ACAD*) returns "AutoCAD"
;; 示例 (MJ:Name *MS*)返回"*Model_Space"
(defun MJ:Name (obj)
(if (vlax-property-available-p obj 'Name)
(vlax-get-property obj 'Name)
"<NONE_NAME>"
)
)
;;10.1 [功能] 打开文件名列表
;;verbose:T,nil
;; 示例: (MJ:DocsList T)
;; NOTES: Verbose为T时full path+filename ; nil时filenames
(defun MJ:DocsList (verbose / docname out)
(vlax-for each *DOCS*
(if verbose
(setq docname
(strcat
(vlax-get-property each 'Path)
"\\"
(MJ:Name each)
)
)
(setq docname (MJ:Name each))
)
(setq out (cons docname out))
)
(reverse out)
)
;;10.2 [功能] (打开文件 未打开文件)列表
;;示例(car (MJ:DocsList1 DwgFileLst))取得列表文件中打开的文件列表
(defun MJ:DocsList1 (DwgFileLst / OPENFILELST)
(setq OpenFileLst (vl-remove-if 'VL-FILE-SYSTIME DwgFileLst)
DwgFileLst(vl-remove-if-not 'VL-FILE-SYSTIME DwgFileLst)
)
(if DwgFileLst
(setq DwgFileLst (vl-sort DwgFileLst '<))
)
(if OpenFileLst
(setq OpenFileLst (vl-sort OpenFileLst '<))
)
(list OpenFileLst DwgFileLst)
)
;;11 [功能] 查询对象属性和方法
(defun C:HHDump (/ ent)
(while (setq ent (entsel))
(vlax-Dump-Object
(vlax-Ename->Vla-Object (car ent))
)
)
(princ)
)
;;12 [功能] 设置 Qleader 命令“引线设置”对话框的相关参数
;;注：<font color=\"red\">引线的箭头跟DIMSTYLE使用同一设置，可以直接修改DIMLDRBLK系统变量</font>
;;2011.5.5 by caoyin
(defun QleaderSet (/ DICEN)
(setq DICEN (namedobjdict));(enget DICEN)可查看内容(3 . 词典)
(if (dictsearch DICEN "AcadDim")
(dictremove DICEN "AcadDim")
)
(dictadd DICEN
"AcadDim"
(entmakex '((0 . "XRECORD")
(100 . "AcDbXrecord")
(280 . 1)
(90 . 990106)
(3 . "");;-----引线和箭头-〉箭头[用户箭头的缺省块名，""则表示未设置]
(60 . 0);;-----注释-〉注释类型
(61 . 0);;-----注释-〉重复使用注释
(62 . 1);;-----附着-〉文字在右边
(63 . 1);;-----附着-〉文字在左边
(64 . 0);;-----附着-〉最后一行加下划线
(65 . 0);;-----引线和箭头-〉引线
(66 . 0);;-----引线和箭头-〉点数-〉无限制
(67 . 3);;-----引线和箭头-〉点数[任意正整数]
(68 . 1);;-----注释-〉多行文字选项-〉提示输入宽度
(69 . 0);;-----注释-〉多行文字选项-〉始终左对齐
(70 . 0);;-----引线和箭头-〉角度约束->第一段
(71 . 0);;-----引线和箭头-〉角度约束->第二段
(72 . 0);;-----注释-〉多行文字选项-〉文字边框
(40 . 0.0)
(170 . 2);;----控制“引线设置”对话框的缺省选项卡
;; (340 . 图元名)
;;-----当DXF组码60的值为3，且已经设定了块参照的块名，则340组码才会出现
;;-----格式为(340 . 上次使用块参照作为注释对象，实际插入的块实例的图元名)
)
)
)
)
;;13 [功能] 求点集中最远，最近点表 ;By 无痕
;:(最远两点 最近两点)
;;示例(MJ:lensort (while (setq pt(getpoint)) (setq plst (cons pt plst)))))
;;(((14857.8 -599.932 0.0) (26695.2 -3687.68 0.0)) ((15733.8 -3687.68 0.0) (15630.7 -3842.07 0.0)))
(defun MJ:lensort (ptlst / pt d maxd mind maxl minl)
(setq minl (list (car ptlst) (cadr ptlst))
maxd 0
mind (apply 'distance minl)
)
(while (setq pt (car ptlst)
ptlst (cdr ptlst)
)
(foreach n ptlst
(setq d (distance n pt))
(cond ((< maxd d)
(setq maxd d
maxl (list n pt)
)
)
((> mind d)
(setq mind d
minl (list n pt)
)
)
)
)
)
(list maxl minl)
)
;;14.1 [功能] 返回指定集合的数量
;; 示例: (MJ:CollectionCount (MJ:GetLayers)))
(defun MJ:CollectionCount (Collection)
(vlax-get-property Collection 'Count)
)
;;14.2 [功能] 返回文档集合的数量
(defun MJ:DocsCount ()
(vlax-get-property *DOCS* 'Count)
)
;;15 [功能] 返回文档指定对象的属性
;;Cname: Active,ActiveDimStyle,ActiveLayer,ActiveLayout,ActiveLinetype,ActivePViewport,ActiveSelectionSet,
;;ActiveSpace,ActiveTextStyle,ActiveUCS,ActiveViewport,Application,Blocks,Database,Dictionaries,DimStyles,
;;ElevationModelSpace,ElevationPaperSpace,FileDependencies,FullName,Groups,Height,HWND,Layers,Layouts,Limits,
;;Linetypes,ModelSpace,MSpace, Name,ObjectSnapMode,PaperSpace,Path,PickfirstSelectionSet,Plot,PlotConfigurations,
;;Preferences,ReadOnly,RegisteredApplications,Saved,SelectionSets,SummaryInfo,TextStyles,UserCoordinateSystems,Utility,
;;Viewports,Views,Width,WindowState,WindowTitle
;;示例 (MJ:DocCollection "WindowState")
(defun MJ:DocCollection (Cname)
(vlax-Get-Property *DOC* Cname)
)
;;15.1 [功能] 图层集合
(defun MJ:GetLayers () (vlax-Get-Property *DOC* 'Layers))
;;15.2 [功能] 线型集合
(defun MJ:GetLtypes () (vlax-Get-Property *DOC* 'Linetypes))
;;15.3 [功能] 文字样式集合
(defun MJ:GetTextStyles () (vlax-Get-Property *DOC* 'TextStyles))
;;15.4 [功能] 尺寸样式集合
(defun MJ:GetDimStyles () (vlax-Get-Property *DOC* 'DimStyles))
;;15.5 [功能] 布局集合
(defun MJ:GetLayouts () (vlax-Get-Property *DOC* 'Layouts))
;;15.6 [功能] 词典集合
(defun MJ:GetDictionaries () (vlax-Get-Property *DOC* 'Dictionaries))
;;15.7 [功能] 块集合(不是我们平时绘图时所说的块)
(defun MJ:GetBlocks () (vlax-Get-Property *DOC* 'Blocks))
;;15.8 [功能] 打印配置集合
(defun MJ:GetPlotConfigs ()(vlax-Get-Property *DOC* 'PlotConfigurations))
;;15.9 [功能] 视图集合
(defun MJ:GetViews () (vlax-Get-Property *DOC* 'Views))
;;15.10 [功能] 视口集合
(defun MJ:GetViewports () (vlax-Get-Property *DOC* 'Viewports))
;;15.11 [功能] 组集合
(defun MJ:GetGroups () (vlax-Get-Property *DOC* 'Groups))
;;15.12 [功能] 注册程序集合
(defun MJ:GetRegApps () (vlax-Get-Property *DOC* 'RegisteredApplications))
;;16 [功能] 返回集合成员名称列表
;;示例 (MJ:ListCollectionMemberNames (MJ:GetLayers))返回:图层列表("0" "中心线" "文字" "DIM")
(defun MJ:ListCollectionMemberNames (collection / out)
(vlax-for each collection
(setq out (cons (MJ:Name each) out))
)
(reverse out)
)
;;16.1 [功能] 返回线型集合成员名称列表(常量*LTS*)
(defun MJ:ListLtypes ()
(MJ:ListCollectionMemberNames (vlax-Get-Property *DOC* 'Linetypes))
)
;;16.2 [功能] 图层列表(常量*LAYS*)
;;示例("0" "中心线" "文字" "DIM")
(defun MJ:ListLayers ()
(MJ:ListCollectionMemberNames (vlax-Get-Property *DOC* 'Layers))
)
;;16.3 [功能] 返回文字样式集合成员名称列表(常量*STS*)
(defun MJ:ListTextStyles ()
(MJ:ListCollectionMemberNames (vlax-Get-Property *DOC* 'TextStyles))
)
;;16.4 [功能] 返回尺寸样式集合成员名称列表
(defun MJ:ListDimStyles ()
(MJ:ListCollectionMemberNames *DIMS*)
)
;;16.5 [功能] 返回布局集合成员名称列表
(defun MJ:ListLayouts ()
(MJ:ListCollectionMemberNames *LOUTS*)
)
;;16.6 [功能] 返回词典集合成员名称列表
(defun MJ:ListDictionaries ()
(MJ:ListCollectionMemberNames *DICS*)
)
;;16.7 [功能] 返回块集合成员名称列表
(defun MJ:ListBlocks ()
(MJ:ListCollectionMemberNames *BLKS*)
)
;;16.8 [功能] 返回打印配置集合成员名称列表
(defun MJ:ListPlotConfigs ()
(MJ:ListCollectionMemberNames (MJ:GetPlotConfigs))
)
;;16.9 [功能] 返回视图集合成员名称列表
(defun MJ:ListViews ()
(MJ:ListCollectionMemberNames (MJ:GetViews))
)
;;16.10 [功能] 返回视口集合成员名称列表(同常量*VPS*)
(defun MJ:ListViewPorts ()
(MJ:ListCollectionMemberNames (MJ:GetViewports))
)
;;16.11 [功能] 返回组集合成员名称列表
(defun MJ:ListGroups ()
(MJ:ListCollectionMemberNames (MJ:GetGroups))
)
;;16.12 [功能] 返回注册程序集合成员名称列表
(defun MJ:ListRegApps ()
(MJ:ListCollectionMemberNames (MJ:GetRegApps))
)
;;17 [功能] 点表排序(141 143.1的更差)
;;*****************************************************************************通用点表排序
;;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)
;;本程序是在fsxm的扩展 自贡黄明儒 2013年9月9日
(defun HH:ssPts:Sort (ssPts KEY FUZZ / E EN FUN LST N SORTPTS SORTSS)
;;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))
)
)
)
)
)
;;*****************************************************************************通用点表排序
;;18 [功能] 集合->列表
;; 示例: (MJ:CollectionList (MJ:GetLtypes)) 返回:线性列表
(defun MJ:CollectionList (Collection / name out)
(vlax-for each Collection
(setq name (MJ:Name each))
(setq out (cons name out))
)
(reverse out)
)
;;19 [功能] 线型数量
(defun MJ:CountLtypes ()
(MJ:CollectionCount (vlax-Get-Property *DOC* 'Linetypes))
)
;;20 [功能] 对集合对象的每个成员执行指定函数的操作
;; 示例: (MJ:MapCollection all-arcs 'MJ:DeleteObject)
(defun MJ:MapCollection (Collection qFunction)
(vlax-map-collection Collection qFunction)
)
;;20.1 [功能] 显示集合对象每个成员的方法和属性.既然是集合,方法是相同的
;; 示例: (MJ:DumpCollection (MJ:GetLayers))
(defun MJ:DumpCollection (Collection)
(MJ:MapCollection Collection 'vlax-dump-object)
)
;;20.2 [功能] 删除对象
;; 示例: (MJ:DeleteObject arc-object1)
(defun MJ:DeleteObject (obj)
(princ "\n ***DeleteObject")
(cond
((and
(not (vlax-erased-p obj));存在
(vlax-read-enabled-p obj);可读
(vlax-write-enabled-p obj);可写
)
(vlax-invoke-method obj 'Delete)
(if (not (vlax-object-released-p obj))
(vlax-release-object obj);释放
)
)
(T (princ "\nCannot delete object!"))
)
)
;;21.1 [功能] ename->vla对象
;; 示例: (MJ:MakeObject (car (entsel)))
(defun MJ:MakeObject (entname)
(cond
((= (type entname) 'ENAME)
(*En2Obj* entname)
)
((= (type entname) 'VLA-OBJECT)
entname
)
)
)
;;21.2 [功能] vla对象->ename
(defun MJ:MakeEname (object)
(if (equal (type object) 'vla-object)
(*Obj2En* object)
object
)
)
;;22 [功能] 返回对象名称(见9)
;; 示例: (= "AcDbArc" (MJ:ObjectType MJ:object))
(defun MJ:ObjectType (obj)
(vlax-get-property obj 'ObjectName)
)
;;23.1 编组开始(command "_.undo" "be")
(defun MJ:UndoBegin ()
(vlax-invoke-method *DOC* 'StartUndoMark)
)
;;23.2 编组结束(command "_.undo" "END")
(defun MJ:UndoEnd ()
(vlax-invoke-method *DOC* 'EndUndoMark)
)
;;24 [功能] 用一个对象的属性等修改另一个对象的属性
;;示例(setq source (MJ:MakeObject(car (entsel))) target (MJ:MakeObject(car (entsel))))
;; (MJ:CopyProp "Layer" sourcetarget)用一个对象的图层等修改另一个对象的图层等
(defun MJ:CopyProp (propName source target)
(cond
((member (strcase propName)
'("LAYER" "LINETYPE" "COLOR"
"LINETYPESCALE""LINEWEIGHT" "PLOTSTYLENAME"
"ELEVATION""THICKNESS"
)
)
(cond
((and
(not (vlax-erased-p source));存在
(not (vlax-erased-p target));存在
(vlax-read-enabled-p source);可读
(vlax-write-enabled-p target);可写
)
(vlax-put-property
target
propName
(vlax-get-property source propName);修改
)
)
(T (princ "\n One or more objects inaccessible!"))
)
)
(T (princ "\n Invalid property-key request!"))
)
)
;;24.1 [功能] 用一个对象的'(图层 线型...)修改另一个对象的图层 线型...等
;; 示例: (MJ:MapPropertyList '("Layer" "Color") arc-object1 arc-object2
(defun MJ:MapPropertyList (propList source target)
(foreach prop propList
(MJ:CopyProp prop source target)
)
)
;;25.1 [功能] 配置文件集合
(defun MJ:Profiles ()
(vla-get-Profiles (MJ:AcadPrefs))
)
;;25.2 [功能] 设置配置文件
;; 示例: (MJ:SetProfile "MJ:Profile")
(defun MJ:SetProfile (pname)
(vl-load-com)
(vla-put-ActiveProfile
(vla-get-Profiles
(vla-get-Preferences
*ACAD*
)
)
pname
)
)
;;25.3 [功能] 重新装载配置文件
;; 示例: (MJ:ProfileReLoad "profile1" "c:\\profiles\\profile1.arg")
(defun MJ:ProfileReLoad (name ARGname)
(cond
((= (vlax-get-property (MJ:Profiles) 'ActiveProfile) name)
;; or following code.
;;(= (vla-get-ActiveProfile (MJ:Profiles)) name)
(princ "\nCannot delete a profile that is in use.")
)
((and
(MJ:ProfileExists-p name)
(findfile ARGname)
)
(MJ:ProfileDelete name)
(MJ:ProfileImport name ARGname)
(vla-put-ActiveProfile (MJ:Profiles) name)
)
((and
(not (MJ:ProfileExists-p name))
(findfile ARGname)
)
(MJ:ProfileImport name ARGname)
(vla-put-ActiveProfile (MJ:Profiles) name)
)
((not (findfile ARGname))
(princ (strcat "\nCannot locate ARG source: " ARGname))
)
)
)
;;25.4 [功能] 重启默认配置文件
;; 示例: (MJ:ProfileReset "profile1")
(defun MJ:ProfileReset (strName)
(if (MJ:ProfileExists-p strName)
(vlax-Invoke-Method
(MJ:Profiles)
'ResetProfile
strName
)
(princ (strcat "\nProfile [" strName "] does not exist."))
)
)
;;25.5 [功能] 输出配置文件
;; ARGS: arg-file(string), profile-name(string), T(Boolean)
;; 示例: (MJ:ProfileExport "<<Unnamed Profile>>" "D:/test.arg" T)
(defun MJ:ProfileExport (strName strFilename BooleReplace)
(if (MJ:ProfileExists-p strName)
(if (not (findfile strFilename))
(progn
(vlax-Invoke-Method
(vlax-Get-Property (MJ:AcadPrefs) "Profiles")
'ExportProfile
strName
strFilename
)
T
)
(if BooleReplace
(progn
(vl-file-delete (findfile strFilename))
(if (not (findfile strFilename))
(progn
(vlax-Invoke-Method
(vlax-Get-Property (MJ:AcadPrefs) "Profiles")
'ExportProfile
strName
strFilename
)
T
)
(princ "\nCannot replace ARG file, aborted.")
)
)
(princ (strcat "\n" strFilename " already exists, aborted.")
)
)
)
)
)
;;25.6 [功能] 输出配置文件
;; NOTES: Export an existing profile to a new external .ARG file
;; 示例: (MJ:ProfileExportX "<<Unnamed Profile>>" "D:/test1.arg")
(defun MJ:ProfileExportX (pName ARGfile)
(cond
((MJ:ProfileExists-p pName)
(vlax-invoke-method
(MJ:Profiles)
'ExportProfile
pName
ARGfile
(vlax-make-variant 1 :vlax-vbBoolean)
;; == TRUE
)
)
(T (princ "\nNo such profile exists to export."))
)
)
;;25.7 [功能] 输入配置文件
;; ARGS: profile-name(string), arg-file(string)
;; 示例: (MJ:ProfileImport "MJ:Profile" "c:/test.arg")
;; VBA equivalent: ;;
;;ThisDrawing.Application.preferences._ ;;
;; Profiles.ImportProfile _ ;;
;; strProfileToImport, strARGFileSource, True ;;
(defun MJ:ProfileImport (pName ARGfile)
(cond
((findfile ARGfile)
(vlax-invoke-method
(vlax-get-property (MJ:AcadPrefs) "Profiles")
'ImportProfile
pName
ARGfile
(vlax-make-variant 1 :vlax-vbBoolean)
;; == TRUE
)
) ;
(T (princ "\nARG file not found to import!"))
)
)
;;25.8 [功能] 复制配置文件
;; 示例: (MJ:ProfileCopy pName newName)
(defun MJ:ProfileCopy (Name1 Name2)
(cond
((and
(MJ:ProfileExists-p Name1)
(not (MJ:ProfileExists-p Name2))
)
(vlax-invoke-method
(MJ:Profiles)
'CopyProfile
Name1
Name2
)
) ;
((not (MJ:ProfileExists-p Name1))
(princ "\nError: No such profile exists.")
) ;
((MJ:ProfileExists-p Name2)
(princ "\nProfile already exists, copy failed.")
)
)
)
;;25.9 [功能] 重命名配置文件
;; 示例: (MJ:ProfileRename oldName newName)
(defun MJ:ProfileRename (oldName newName)
(cond
((and
(MJ:ProfileExists-p oldName)
(not (MJ:ProfileExists-p newName))
)
(vlax-invoke-method
(MJ:Profiles)
'RenameProfile
oldName
newName
)
)
(T (princ))
;; add your error handling here?
)
)
;;25.10 [功能] 删除配置文件
;; 示例: (MJ:ProfileDelete "MJ:Profile")
(defun MJ:ProfileDelete (pName)
(vlax-invoke-method
(vlax-get-property (MJ:AcadPrefs) "Profiles")
'DeleteProfile
pName
)
)
;;25.11 [功能] 配置文件是否存在
;; 示例: (if (MJ:ProfileExists-p "<<Unnamed Profile>>") ...)
(defun MJ:ProfileExists-p (pName)
(member (strcase pName) (mapcar 'strcase (MJ:ProfileList)))
)
;;25.12 [功能] 配置文件列表
;;返回示例("<<Unnamed Profile>>" "yky_m2006")
(defun MJ:ProfileList (/ hold)
(vlax-invoke-method
(vlax-get-property (MJ:AcadPrefs) "Profiles")
'GetAllProfileNames
'hold
)
(if hold
(vlax-safearray->list hold)
)
)
;;26.1 [功能] 非当前文档,关闭(不保存)
;; Author: Frank Whaley
(defun MJ:CloseAll (/ item cur)
(vl-load-com)
(vlax-for item *DOCS*
(if (= (vla-get-active item) :vlax-false)
(vla-close item :vlax-false)
(setq cur item)
)
)
;;(vla-sendcommand cur "_.CLOSE")
(command "vbastmt" "AcadApplication.activeDocument.close false ");关闭当前文档
)
;;27.1 [功能] 保存所有文档
(defun MJ:SaveAllDocs (/ item)
(vlax-for item *DOCS*
(vla-save item)
)
)
;;27.2 [功能] 活动文档是否已经保存?
(defun MJ:Saved-p ()
(= (vla-get-saved *DOC*) :vlax-True)
)
;;acR12_DXF,AutoCAD Release12/LT2 DXF (*.dxf)
;;ac2000_dwg,AutoCAD 2000 DWG (*.dwg)
;;ac2000_dxf,AutoCAD 2000 DXF (*.dxf)
;;ac2000_Template,AutoCAD 2000 Drawing Template File (*.dwt)
;;ac2004_dwg,AutoCAD 2004 DWG (*.dwg)
;;ac2004_dxf,AutoCAD 2004 DXF (*.dxf)
;;ac2004_Template,AutoCAD 2004 Drawing Template File (*.dwt)
;;acNative,A synonym for the current drawing release format
;;AcUnknown,Read-only. The drawing type is unknown or invalid.
;;27.3 [功能] 另存为2K格式
(defun MJ:SaveAs2000 (name)
(vla-saveas *DOC* name acR15_DWG)
)
;;27.4 [功能] 另存为R14格式
(defun MJ:SaveAsR14 (name)
(vla-saveas *DOC* name acR14_DWG)
)
;;28.1 [功能] 清理打开文档
(defun MJ:PurgeAllDocs (/ item cur)
(vlax-for item *DOCS*
(vla-PurgeAll item)
)
)
;;28.2 [功能] 删除未使用的图层,比purge彻底
(defun MJ:LayerDelete ()
(vl-Load-Com)
(vl-Catch-All-Apply
'(lambda ()
(vla-Remove
(vla-GetExtensionDictionary
(vla-Get-Layers
*DOC*
)
)
"ACAD_LAYERFILTERS"
)
)
)
(princ)
)
;;29.1 [功能] 取得选定块的指定属性
;; (MJ:GetTagTextStringByRef (*En2Obj* (car (entsel))) "设计")
(defun MJ:GetTagTextStringByRef (br tagname / atts tag str)
(if (and
(= (vla-get-hasattributes br) :vlax-true)
(safearray-value
(setq atts
(vlax-variant-value
(vla-getattributes br)
)
)
)
)
(foreach tag (vlax-safearray->list atts)
(if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
(setq str (vla-get-TextString tag))
)
)
)
str
)
;;29.2 [功能] 取得块属性列表
;(MJ:GetAttributes (car (entsel)))取得属性列表(("比例" . "") ("材料" . "Q235"))
(defun MJ:GetAttributes (ent / blkref lst)
(if (= (vla-Get-ObjectName
(setq blkref (vlax-Ename->vla-Object ent))
)
"AcDbBlockReference"
)
(if (vla-Get-HasAttributes blkref)
(mapcar
'(lambda (x)
(setq
lst (cons
(cons (vla-Get-TagString x) (vla-Get-TextString x))
lst
)
)
)
(vlax-safearray->list
(vlax-variant-value (vla-GetAttributes blkref))
)
)
)
)
(reverse lst)
)
;;29.3 [功能] [功能] 取得块属性列表
;; 示例: (MJ:GetAttributes (car (entsel))返回(("比例" "" <Entity name: 7efd2ad0>)(...))
(defun MJ:GetAttributes (ent / lst)
(if (safearray-value
(setq lst
(vlax-variant-value
(vla-getattributes
(vlax-ename->vla-object ent)
)
)
)
)
(mapcar
'(lambda (x)
(list
(vla-get-tagstring x)
(vla-get-textstring x)
(*Obj2En* x)
)
)
(vlax-safearray->list lst)
)
)
)
;;29.4 [功能] Returns a list of constant attributes tags and their values
;; 示例: (MJ:GetConstantAttributes (car (entsel)))
(defun MJ:GetConstantAttributes (ent / atts)
(vl-load-com)
(cond
((and (safearray-value
(setq atts
(vlax-variant-value
(vla-getconstantattributes
(vlax-ename->vla-object ent)
)
)
)
)
)
(mapcar
'(lambda (x)
(cons (vla-get-tagstring x) (vla-get-textstring x))
)
(vlax-safearray->list atts)
)
) ;
(T
(princ
(strcat
"\nThe block reference \""
(vla-get-Name (vlax-ename->vla-object ent))
"\" doesn't include constant attributes tags and their values"
)
)
)
)
)
;;30.1 [功能] 更改块指定属性
;; (MJ:PutTagTextString "块名" tagname "new value")
(defun MJ:PutTagTextString
(bn tagname textstring / layout i atts tag)
(vlax-for layout *LOUTS*
(vlax-for i (vla-get-block layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(= (strcase (vla-get-name i)) (strcase bn))
)
(if (and
(= (vla-get-hasattributes i) :vlax-true)
(safearray-value
(setq atts
(vlax-variant-value
(vla-getattributes i)
)
)
)
)
(foreach tag (vlax-safearray->list atts)
(if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
(vla-put-TextString tag textstring)
)
)
(vla-update i)
)
)
)
)
)
;;30.2 [功能] 块的属性值改为新值---纯lisp法 by 自贡黄明儒
;;示例(attchg (car (entsel)) "设计" "aaa")
(defun attchg (ent attname new / EN ENTLIST)
(defun MJ:DXF (IT LST)
(cdr (assoc IT LST))
)
(if (and (setq en ent)
(setq entlist (entget en))
(equal (MJ:DXF 0 entlist) "INSERT")
(equal (MJ:DXF 66 entlist) 1) ;=1则块有属性值
)
(while (and en
(setq en (entnext en))
(setq entlist (entget en))
(equal (MJ:DXF 0 entlist) "ATTRIB")
)
(if (= (strcase (MJ:DXF 2 entlist)) (strcase attname))
(progn (entmod (subst (cons 1 new) (assoc 1 entlist) entlist))
(entupd ent)
(setq en nil)
)
)
)
)
(princ)
)
;;30.3 [功能] 更改选定块的指定属性
;; (MJ:PutTagTextStringByRef (*En2Obj* (car (entsel))) "设计" "new value")
(defun MJ:PutTagTextStringByRef (br tagname textstring / atts tag)
(if (and
(= (vla-get-hasattributes br) :vlax-true)
(safearray-value
(setq atts
(vlax-variant-value
(vla-getattributes br)
)
)
)
)
(foreach tag (vlax-safearray->list atts)
(if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
(vla-put-TextString tag textstring)
)
)
(vla-update br)
)
)
;;30.4 [功能] 更改块多个属性
;;(setq blk (car (entsel)))
;;(MJ:ChangeAttributes (list blk (cons "设计" "AA")(cons "名称" "BB")))
(defun MJ:ChangeAttributes (lst / blk itm atts)
(setq blk (vlax-Ename->vla-Object (car lst))
lst (cdr lst)
)
(if (= (vla-Get-HasAttributes blk) :vlax-true) ;如果有属性
(progn
(setq atts (vlax-SafeArray->list
(vlax-Variant-Value (vla-GetAttributes blk))
)
)
(foreach item lst
(mapcar
'(lambda (x)
(if
(= (strcase (car item)) (strcase (vla-Get-TagString x)))
(vla-Put-TextString x (cdr item))
)
)
atts
)
)
(vla-Update blk)
)
)
)
;;30.5 [功能] 更改块多个属性
;; 示例: (MJ:ChangeAttribute (list ename '("MJ:Attribute" . "NewValue")))
;; 示例 (MJ:ChangeAttribute (list (car (entsel)) '("设计" . "NewValue")))
(defun MJ:ChangeAttribute (lst / item atts)
(vl-load-com)
(if (safearray-value
(setq atts
(vlax-variant-value
(vla-getattributes (vlax-ename->vla-object (car lst)))
)
)
)
(progn
(foreach item (cdr lst)
(mapcar
'(lambda (x)
(if
(= (strcase (car item)) (strcase (vla-get-tagstring x)))
(vla-put-textstring x (cdr item))
)
)
(vlax-safearray->list atts)
)
)
(vla-update (vlax-ename->vla-object (car lst)))
)
)
)
;;31.1 [功能] 返回指定(块名 标记 属性值)的块 选择集
;; 示例: (MJ:SelectAttributedBlocks '("块名" "Tag" "value"))
(defun MJ:SelectAttributedBlocks (lst / ss ss2 c ent att)
(if (setq ss (ssget "X" (list (cons 0 "INSERT") (cons 2 (car lst)))))
(progn
(setq c 0)
(repeat (sslength ss)
(setq ent (vlax-ename->vla-object (ssname ss c)))
(if (vla-get-hasattributes ent)
(foreach att (vlax-safearray->list
(vlax-variant-value (vla-getattributes ent))
)
(if
(= (strcase (vla-get-tagstring att)) (strcase (cadr lst)))
(if (= (strcase (vla-get-textstring att))
(strcase (caddr lst))
)
(progn
(vla-highlight ent :vlax-true)
(if (not ss2)
(setq ss2 (ssadd (ssname ss c)))
(ssadd (ssname ss c) ss2)
)
)
)
)
)
)
(setq c (1+ c))
)
)
)
ss2
)
;;31.2 [功能] 返回指定(块名 标记 属性值)的块 选择集
;; (MJ:FindBlockTagValue "blockname" "tagname" "tagvalue")
(defun MJ:FindBlockTagValue
(bn tagname value / layout i atts tag sset c)
(vlax-for layout *LOUTS*
(vlax-for i (vla-get-block layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(= (strcase (vla-get-name i)) (strcase bn))
)
(if (and
(= (vla-get-hasattributes i) :vlax-true)
(safearray-value
(setq atts
(vlax-variant-value
(vla-getattributes i)
)
)
)
)
(progn
(foreach tag (vlax-safearray->list atts)
(if (and
(= (strcase tagname)
(strcase (vla-get-TagString tag))
)
(= value (vla-get-TextString tag))
)
(progn
(if (not sset)
(setq sset (ssadd (*Obj2En* i)))
(ssadd (*Obj2En* i) sset)
)
)
)
)
)
)
)
)
)
(sssetfirst nil sset)
)
;;32.1 [功能] 更改属性位置
;; (MJ:ChangeTagIns "sheet-text" "a3-scale" '(703.4722 17.8350 0))
(defun MJ:ChangeTagIns (bn tagname ins / layout i atts tag)
(defun list->variantArray (ptsList / arraySpace sArray)
(setq arraySpace
(vlax-make-safearray
vlax-vbdouble
(cons 0 (- (length ptsList) 1))
)
)
(setq sArray (vlax-safearray-fill arraySpace ptsList))
(vlax-make-variant sArray)
)
(vlax-for layout *LOUTS*
(vlax-for i (vla-get-block layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(= (strcase (vla-get-name i)) (strcase bn))
)
(if (and
(= (vla-get-hasattributes i) :vlax-true)
(safearray-value
(setq atts
(vlax-variant-value
(vla-getattributes i)
)
)
)
)
(foreach tag (vlax-safearray->list atts)
(if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
(vla-put-InsertionPoint tag (list->variantArray ins))
)
)
(vla-update i)
)
)
)
)
)
;;32.2 [功能] 更改块属性宽度
;; (MJ:ChangeTagWidth <block name> <tag name> <tag height>)
;; (MJ:ChangeTagWidth "panel1" "drw-no" 0.97)
(defun MJ:ChangeTagWidth (bn tagname tagwidth / layout i atts tag)
(vlax-for layout *LOUTS*
(vlax-for i (vla-get-block layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(= (strcase (vla-get-name i)) (strcase bn))
)
(if (and
(= (vla-get-hasattributes i) :vlax-true)
(safearray-value
(setq atts
(vlax-variant-value
(vla-getattributes i)
)
)
)
)
(foreach tag (vlax-safearray->list atts)
(if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
(vla-put-scalefactor tag tagwidth)
)
)
(vla-update i)
)
)
)
)
)
;;32.3 [功能] 更改块属性高度
;; (MJ:ChangeTagHeight <block name> <tag name> <tag height>)
;; (MJ:ChangeTagHeight "sheet-text" "client-drw" 0.97)
(defun MJ:ChangeTagHeight
(bn tagname tagheight / layout i atts tag)
(vlax-for layout *LOUTS*
(vlax-for i (vla-get-block layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(= (strcase (vla-get-name i)) (strcase bn))
)
(if (and
(= (vla-get-hasattributes i) :vlax-true)
(safearray-value
(setq atts
(vlax-variant-value
(vla-getattributes i)
)
)
)
)
(foreach tag (vlax-safearray->list atts)
(if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
(vla-put-height tag tagheight)
)
)
(vla-update i)
)
)
)
)
)
;;33 [功能] 列表块插入点(Y排序)
;; (MJ:ListBlockIns "BTL")
;; return value example:
;; ((341.385 29.2937 0.0 #<VLA-OBJECT IAcadBlockReference 071b9e24>)
;;(341.385 34.2937 0.0 #<VLA-OBJECT IAcadBlockReference 071b9e74>)
;;(341.385 39.2937 0.0 #<VLA-OBJECT IAcadBlockReference 071bd184>))
(defun MJ:ListBlockIns (bn / layout i pl)
(vlax-for layout *LOUTS*
(vlax-for i (vla-get-block layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(= (strcase (vla-get-name i)) (strcase bn))
)
(setq pl
(cons
(append (safearray-value
(vlax-variant-value (vla-get-InsertionPoint i))
)
(list i)
)
pl
)
)
)
)
)
; sort by y-value
(vl-sort pl
(function (lambda (e1 e2)
(< (cadr e1) (cadr e2))
)
)
)
)
;;34 [功能] 块集的某一属性,显示块的x(or y z)值
;; Arguments: ss块集attname属性 ordinate(0=X, 1=Y, 2=Z)
;; 示例: (MJ:LabelOrdinate ss "设计" 0)
(defun MJ:LabelOrdinate (ss attname ordinate / c block atts val att)
(vl-load-com)
(setq c -1)
(repeat (sslength ss)
(setq block (vlax-ename->vla-object
(ssname ss (setq c (1+ c)))
)
atts (vlax-safearray->list
(vlax-variant-value
(vla-getattributes block)
)
)
val (rtos
(nth ordinate
(vlax-safearray->list
(vlax-variant-value
(vla-get-insertionpoint block)
)
)
)
2
0
)
)
(foreach att atts
(if (= (strcase attname) (strcase (vla-get-tagstring att)))
(vla-put-textstring att val)
)
)
(vla-update block)
)
(princ)
)
;;35.1 [功能] 块中删除对象
;; 示例: (MJ:DeleteObjectFromBlock (car (nentsel)))
;; Notes: 1. As shown, you can use the NENTSEL function to obtain the name of an entity within a block.
;; 2. Existing block reference will not show a change until you regen the drawing.
(defun MJ:DeleteObjectFromBlock (ent / doc blk)
(setq ent (vlax-ename->vla-object ent)
blk (vla-ObjectIdToObject *DOC* (vla-get-OwnerID ent))
)
(vla-Delete ent)
(vla-get-Count blk)
)
;;35.2 [功能] 块增加对象
;; 示例: (MJ:AddObjectsToBlock (car (entsel)) (ssget))
;; Notes: Existing block references will not show a change until you
;; regen the drawing
(defun MJ:AddObjectsToBlock (blk ss / doc blkref blkdef inspt refpt)
(vl-load-com)
(setq blkref (vlax-ename->vla-object blk)
blkdef (vla-Item (vla-get-Blocks *DOC*) (vla-get-Name blkref))
inspt (vlax-variant-value (vla-get-InsertionPoint blkref))
ssarray (SS->Array ss)
refpt (vlax-3d-point '(0 0 0))
)
(foreach ent (vlax-safearray->list ssarray)
(vla-Move ent inspt refpt)
)
(vla-CopyObjects *DOC* ssarray blkdef)
(foreach ent (vlax-safearray->list ssarray)
(vla-Delete ent)
)
(princ)
)
;;35.3[功能] 返回指定块每一个引用实体名列表
;; 注:未能验证是否正确?(MJ:ListBLockRefs "BTL")
(defun MJ:ListBLockRefs (blkName / lst)
(setq lst (entget
(cdr
(assoc 330 (entget (tblobjname "block" blkName)))
)
)
)
(apply
'append
(mapcar '(lambda (x)
(if (entget (cdr x))
(list (cdr x))
)
)
(repeat 2
(setq lst (reverse (cdr (member (assoc 102 lst) lst))))
)
)
)
)
;;35.4 [功能] 块引用名列表Returns a list conaining the entity names of any block definitions that
;; reference the specified block
;; 示例: (MJ:GetParentBlocks "BTL")
(defun MJ:GetParentBlocks (blkName / doc)
(apply
'append
(mapcar
'(lambda (x)
(if (= :vlax-false
(vla-get-IsLayout
(vla-ObjectIdToObject
*DOC*
(vla-get-OwnerId (vlax-ename->vla-object x))
)
)
)
(list x)
)
)
(MJ:ListBLockRefs blkName)
)
)
)
;;36 [功能] 删除指定名的所有块
;; (MJ:EraseBlock "BTL");删除名叫"BTL"的所有块
(defun MJ:EraseBlock (bn / layout i)
(vlax-for layout *LOUTS*
(vlax-for i (vla-get-block layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(= (strcase (vla-get-name i)) (strcase bn))
)
(vla-Delete i)
)
)
)
)
;;37 [功能] 块名"BTL"是否存在
;; (MJ:ExistBlock "BTL"是)
(defun MJ:ExistBlock (bn / layout i exist)
(vlax-for layout *LOUTS*
(vlax-for i *BLKS*
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(= (strcase (vla-get-name i)) (strcase bn))
)
(setq exist T)
)
)
)
exist
)
;;38.1 [功能] 块更名(块bn nn必须存在)
;; (MJ:RenameBlock "b1" "b2")块"b1"更名为"b2"
(defun MJ:RenameBlock (bn nn / layout i)
(vlax-for layout *LOUTS*
(vlax-for i (vla-get-block layout)
(if (and
(= (vla-get-objectname i) "AcDbBlockReference")
(= (strcase (vla-get-name i)) (strcase bn))
)
(vla-put-name i nn)
)
)
)
)
;;38.2 [功能] 块更名
;;名为bn的块存在,名为nn的块不存在
;;(MJ:RenameBlock1 "ccd1" "ccd2")
(defun MJ:RenameBlock1 (bn nn / BLOCK)
(vla-put-name (vla-item (vla-get-blocks *DOC*) bn) nn)
)
;;39 [功能] 块名例表
;; 返回示例("*D5" "A$$C263E5435" "b2" "b1")
(defun MJ:blocks (/ b bn tl)
(vlax-for b (vla-get-blocks *DOC*)
(if (= (vla-get-islayout b) :vlax-false)
(setq tl (cons (vla-get-name b) tl))
)
)
(reverse tl)
)
;;40 [功能] XRef图块列表 a list of all xref names
;;返回示例("xref1" "x2")
(defun MJ:xrefs (/ b bn tl)
(vlax-for b (vla-get-blocks *DOC*)
(if (= (vla-get-isxref b) :vlax-true)
(setq tl (cons (vla-get-name b) tl))
)
)
(reverse tl)
)
;;41 [功能] 返回名为"bn"的XRef图块实体列表
;; 返回示例 (<Entity name: 2ea6290> <Entity name: 2ea6288>)
(defun blockrefs (bn / lst ed)
(if (setq ed (tblobjname "block" bn))
(setq
lst (entget
(cdr (assoc 330 (entget ed)))
)
)
)
(apply
'append
(mapcar '(lambda (x)
(list (cdr x))
)
(cdr (reverse (cdr (member (assoc 102 lst) lst))))
)
)
)
;;42 [功能] 返回包容点集的最小点最大点列表
;; (MJ:Extents '((1 0 0) (2 2 0) (1 2 0)))
(defun MJ:Extents (plist /)
(list
(apply 'mapcar (cons 'min plist))
(apply 'mapcar (cons 'max plist))
)
)
;;43.1 [功能] 两点中点
(defun MJ:Mid (pts / P1 P2 X Y)
(setq p1 (car pts) p2 (cadr pts))
(if (= (length p1) (length p2))
nil
(setq p1 (list (car p1) (cadr p1))
p2 (list (car p2) (cadr p2))
)
)
(mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2)
)
;;43.2 [功能] <起点>,<中点>,<终点>列表;By 无痕
(DEFUN xl-3p (e / ps pe pm)
(setq ps (vlax-curve-getstartparam e)
pe (vlax-curve-getendparam e)
pm (/ (- pe ps) 2)
)
(mapcar 'vlax-curve-getpointatparam
(list e e e)
(list ps pm pe)
)
)
;;44 [功能] 求矩形中心
;;示例 (MJ:RectCenter (car (entsel)))
(defun MJ:RectCenter (rec)
(MJ:Mid (MJ:Extents (MJ:Massoc 10 (entget rec))))
)
;;45 [功能] 返回封闭曲线质心二维坐标
;; 示例: (MJ:Centroid (car (entsel)))
(defun MJ:Centroid (poly / pl ms va reg cen)
(vl-load-com)
(setq pl (vlax-ename->vla-object poly)
ms (vla-get-modelspace
*DOC*
)
va (vlax-make-safearray vlax-vbObject '(0 . 0))
)
(vlax-safearray-put-element va 0 pl)
(setq reg (car (vlax-safearray->list
(vlax-variant-value (vla-addregion ms va))
)
)
cen (vla-get-centroid reg)
)
(vla-delete reg)
(vlax-safearray->list (vlax-variant-value cen))
)
;;46.1 [功能] 多段线各顶点(见99.3)
;;示例 (MJ:Massoc 10 (entget (car (entsel))))
;; Notes:特别适合多段线各顶点
(defun MJ:Massoc (key alist)
(apply
'append
(mapcar '(lambda (x)
(if (eq (car x) key)
(list (cdr x))
)
)
alist
)
)
)
;;46.2 [功能] pline,lwpline点坐标表By 无痕
;;示例(vxs (car (entsel))),返回三维点坐标
(defun vxs (e / i v lst)
(setq i -1)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(reverse lst)
)
;;46.3 [功能] 返回包含每一出现在列表中的指定键的cdr(点对的后部分)的列表。
;;;示例 (MJ:massoc 10 (entget (car (entsel))))
;;注意 该函数特别适合用于找到细多义线上的所有顶点。
(defun MJ:massoc (key alist)
(mapcar 'cdr
(vl-remove-if-not '(lambda (x) (equal key (car x))) alist)
)
)
;;47 [功能] 曲线是否封闭
;;(MJ:IsClosed (car (entsel)))封闭返回T,圆返回nil
(defun MJ:IsClosed (epl / vpl)
(setq vpl (MJ:MakeObject epl));转换成Vla
(if (vlax-property-available-p vpl 'Closed)
(= (vlax-get-property vpl 'Closed) :vlax-true)
)
)
;;48 [功能] 返回一个包涵经过pt点的多段线端点的列表
;; Returns a list containing the endpoints of the selected lwpoly segment
;; 示例: (apply 'MJ:GetPolySegment (list (car (entsel)) (getpoint)))返回((-1600.24 2403.92) (-1524.08 2403.92))
(defun MJ:GetPolySegment (poly pt / pts i)
(setq pts (MJ:Massoc 10 (entget poly))
i (caddar (ssnamex (ssget pt)))
)
(list
(nth (1- i) pts)
(if
(and
(MJ:IsClosed poly)
(= i (length pts))
)
(car pts)
(nth i pts)
)
)
)
;;49 [功能] 把弧变成圆
(defun MJ:CloseArc (/ arcent arcobj trapobj circ)
(while (setq arcent (entsel "\nSelect ARC object: "))
(setq arcobj (MJ:MakeObject (car arcent)))
(cond
((= "AcDbArc" (MJ:ObjectType arcobj))
(MJ:UndoBegin)
(setq circ
(vla-addCircle
*MS*
(vla-Get-center arcobj)
(vla-Get-radius arcobj)
)
)
(MJ:MapPropertyList
'("Layer" "Color" "Thickness" "Linetype" "LinetypeScale")
arcobj
circ
)
(MJ:DeleteObject arcobj)
(vlax-Release-Object circ)
(MJ:UndoEnd)
) ;
(T (princ "\nNot an ARC object, try again..."))
) ; cond
) ; endwhile
(princ)
)
;;50.1 [功能] 线型是否存在?
;;示例: (MJ:Ltype-Exists-p "DASHED") (MJ:Ltype-Exists-p "continuous")
(defun MJ:Ltype-Exists-p (strLtype)
(member
(strcase strLtype)
(mapcar 'strcase (MJ:ListLtypes))
)
)
;;50.2 [功能] 改变vla对象线型
;; 示例: (MJ:Apply-Ltype cirobj "DASHED")改变对象线型
(defun MJ:Apply-Ltype (obj strLtype / entlist)
(cond
((MJ:Ltype-Exists-p strLtype)
(cond
((and
(vlax-Read-Enabled-p obj)
(vlax-Write-Enabled-p obj)
)
(vla-Put-Linetype obj strLtype)
T
)
(T (princ "\n Unable to modify object!"))
)
)
(T
(princ (strcat "\n Linetype ["
strLtype
"] not loaded."
)
)
)
)
)
;;51.1 [功能] 角度->弧度
(defun MJ:D2R (a) (* pi (/ a 180.0)))
;;51.2 [功能] 弧度->角度
(defun MJ:R2D (a) (/ (* a 180.0) pi))
;;52.1 [功能] 3D点->2D点 By Caoyin
(defun 3dpoint->2dpoint (3dpt)
(if (apply 'and (mapcar 'numberp 3dpt))
(mapcar '+ 3dpt '(0. 0.))
)
)
;;52.2 [功能] 3D点->2D点
(defun 3d->2d (3dpt / 2dpt)
(setq 2dpt (list (car 3dpt) (cadr 3dpt)))
)
;;52.3 [功能] 3D点列表->2D点列表
(defun 3dpoint-list->2dpoint-list (3dplist / 2dplist)
(cond
((and 3dplist (listp 3dplist) (listp (car 3dplist)))
(setq 2dplist
(mapcar '(lambda (pt) (list (car pt) (cadr pt))) 3dplist)
)
)
(T
(princ
"\n3dpoint-list->2dpoint-list: Invalid parameter list..."
)
)
)
)
;;52.4 [功能] 3D点列表->2D点列表
(defun 3dlist->2dlist (3dplist)
(mapcar '3d->2d 3dplist)
)
;;52.5 [功能] 对表分段
;;(xl_div lst nom)表分段. -> 返回 分段的表. －－－－－－by 无痕.2004.1
; lst ＝ 表，nom = 分段的子表元素个数(从1开始计).
;;示例 (xl_div '(1 2 3 4 5 6 7 8 9) 3) -> ((1 2 3) (4 5 6) (7 8 9))
(defun xl-div (lst x / lst2)
(foreach n lst
(if (and lst2 (/= x (length (car lst2))))
(setq lst2 (cons (append (car lst2) (list n)) (cdr lst2)))
(setq lst2 (cons (list n) lst2))
)
)
(reverse lst2)
)
;;53.1 [功能] 画线
;; 示例:(MJ:AddLine (getpoint) (getpoint) nil nil nil)
(defun MJ:AddLine (StartPt EndPt strLayer intColor strLtype / obj)
(cond
((and StartPt (listp StartPt) EndPt (listp EndPt))
(setq obj (vla-addLine
(vla-Get-ModelSpace
*DOC*
)
(vlax-3D-Point StartPt)
(vlax-3D-Point EndPt)
)
)
(cond
((vlax-Write-Enabled-p obj)
(if strLayer
(vla-Put-Layer obj strLayer)
)
(if intColor
(vla-Put-Color obj intColor)
)
(if strLtype
(MJ:Apply-Ltype obj strLtype)
)
(vla-Update obj)
(vlax-Release-Object obj)
(entlast)
)
(T (princ "\nUnable to modify object properties..."))
)
)
(T (princ "\nMJ:AddLine: Invalid parameter list..."))
)
)
;;53.2 [功能] 根据点表画线
(defun MJ:AddLineC (ptlist Bclosed strLayer intColor strLtype / *MJ:MODELSPACE* PT1 PTZ)
(setq *MJ:ModelSpace* *MS*)
(cond
((and ptlist (listp ptlist) (listp (car ptlist)))
(setq pt1 (car ptlist)
;; save first point
ptz (last ptlist)
;; save last point
)
(while (and ptlist (>= (length ptlist) 2))
(MJ:AddLine
*MJ:ModelSpace*
(car ptlist)
(cadr ptlist)
strLayer
intColor
strLtype
)
(setq ptlist (cdr ptlist))
)
(if (= Bclosed T)
(MJ:AddLine
*MJ:ModelSpace* pt1 ptz strLayer intColor strLtype)
)
)
(T (princ "\nMakeLineC: Invalid parameter list..."))
)
)
;;54 [功能] 画弧
;; 示例: (MJ:AddArc pt1 0.5 0 90 "0" 3 "DASHED")
(defun MJ:AddArc
(CenterPt Radius StartAng EndAng
strLayer intColor strLtype /
obj
)
(cond
((and CenterPt (listp CenterPt) Radius StartAng EndAng)
(setq obj
(vla-addArc
(vla-Get-ModelSpace
*DOC*
)
(vlax-3D-Point CenterPt)
Radius
(MJ:D2R StartAng)
(MJ:D2R EndAng)
)
)
(cond
((vlax-Write-Enabled-p obj)
(if strLayer
(vla-Put-Layer obj strLayer)
)
(if intColor
(vla-Put-Color obj intColor)
)
(if strLtype
(MJ:Apply-Ltype obj strLtype)
)
(vla-Update obj)
(vlax-Release-Object obj)
(entlast)
) ;
(T (princ "\nUnable to modify object properties..."))
)
) ;
(T (princ "\nMJ:AddArc: Invalid parameter list..."))
)
)
;;55 [功能] 画圆
;; 示例: (MJ:AddCircle pt1 0.5 "0" 3 "DASHED")
(defun MJ:AddCircle
(CenterPt Radius strLayer intColor strLtype / obj)
(cond
((and CenterPt (listp CenterPt) Radius)
(setq obj (vla-addCircle
(vla-Get-ModelSpace
*DOC*
)
(vlax-3D-Point CenterPt)
Radius
)
)
(cond
((vlax-Write-Enabled-p obj)
(if strLayer
(vla-Put-Layer obj strLayer)
)
(if intColor
(vla-Put-Color obj intColor)
)
(if strLtype
(MJ:Apply-Ltype obj strLtype)
)
(vla-Update obj)
(vlax-Release-Object obj)
(entlast)
)
(T (princ "\nUnable to modify object properties..."))
)
)
(T (princ "\nMJ:AddCircle: Invalid parameter list..."))
)
)
;;56 [功能] 画多段线
;; EXMAPLE: (MJ:AddPlineptlist "0" T 3 "DASHED" 0.125) ;;
(defun MJ:AddPline
(ptlist strLayerBclosed intColorstrLtype
dblWidth / vrtcs lst plgen
plist plpointsobj
)
(cond
((and ptlist (listp ptlist) (listp (car ptlist)))
(setq plist (apply 'append (mapcar '3dpoint->2dpoint ptlist))
plpoints (MJ:List->VariantArray plist)
obj (vla-AddLightWeightPolyline
(vla-Get-ModelSpace
*DOC*
)
plpoints
)
)
(cond
((and
(vlax-Read-Enabled-p obj)
(vlax-Write-Enabled-p obj)
)
(if Bclosed
(vla-Put-Closed obj :vlax-True)
)
(if strLayer
(vla-Put-Layer obj strLayer)
)
(if intColor
(vla-Put-Color obj intColor)
)
(if dblWidth
(vla-Put-ConstantWidth obj dblWidth)
)
(if strLtype
(progn
(MJ:Apply-Ltype obj strLtype)
(vla-Put-LinetypeGeneration obj :vlax-True)
)
)
(vla-Update obj)
(vlax-Release-Object obj)
(entlast)
)
(T (princ "\n Unable to modify object!"))
)
)
(T (princ "\n Invalid parameter list...."))
)
)
;;56.1 [功能] 画椭圆
;; 示例: (MJ:AddEllipse l1 p2 45 "PARTS" nil nil) ;;
(defun MJ:AddEllipse
(ctr hmpt roll strLayer intColor strLtype / lst obj)
(cond
((and ctr (listp ctr) hmpt (listp hmpt) roll)
(setq hmpt (list
(- (car hmpt) (car ctr))
(- (cadr hmpt) (cadr ctr))
)
obj (vla-addEllipse
*MS*
(vlax-3D-Point ctr)
(vlax-3D-Point hmpt)
(cos (MJ:D2R roll))
)
)
(cond
((vlax-Write-Enabled-p obj)
(if strLayer
(vla-Put-Layer obj strLayer)
)
(if intColor
(vla-Put-Color obj intColor)
)
(if strLtype
(MJ:Apply-Ltype obj strLtype)
)
(vla-Update obj)
)
(T (princ "\nUnable to modify object properties..."))
)
(vlax-Release-Object obj)
(entlast)
)
(T (princ "\nInvalid paprameter list..."))
)
)
;;56.2 [功能] 画椭圆弧
(defun MJ:AddEllipseArc1
(ctr hmpt roll StartAng
EndAng strLayer intColor strLtype
/ obj rang
)
(cond
((and ctr (listp ctr) hmpt roll)
(setq hmpt (list
(- (car hmpt) (car ctr))
(- (cadr hmhp) (cadr ctr))
)
obj (vla-addEllipse
*MS*
(vlax-3D-Point ctr)
(vlax-3D-Point hmpt)
(MJ:Roll->Ratio roll)
)
)
(cond
((vlax-Write-Enabled-p obj)
(vla-Put-StartAngle obj (MJ:D2R StartAng))
(vla-Put-EndAngle obj (MJ:D2R EndAng))
(if strLayer
(vla-Put-Layer obj strLayer)
)
(if intColor
(vla-Put-Color obj intColor)
)
(if strLtype
(MJ:Apply-Ltype obj strLtype)
)
(vla-Update obj)
(vlax-Release-Object obj)
(entlast)
)
(T (princ "\nUnable to modify object properties..."))
)
)
(T (princ "\nMakeArcEllipse1: Invalid parameter list..."))
)
)
;;56.3 [功能] 画椭圆弧
(defun MJ:AddEllipseArc2
(ctr hmpt hmin StartAng
EndAng strLayer intColor strLtype
/ obj rang
)
(cond
((and ctr (listp ctr) hmpt (listp hmpt) hmin)
(setq hmpt (list
(- (car hmpt) (car ctr))
(- (cadr hmpt) (cadr ctr))
)
obj (vla-addEllipse
*MS*
(vlax-3D-Point ctr)
(vlax-3D-Point hmpt)
hmin
)
)
(cond
((vlax-Write-Enabled-p obj)
(vla-Put-StartAngle obj (MJ:D2R StartAng))
(vla-Put-EndAngle obj (MJ:D2R EndAng))
(if strLayer
(vla-Put-Layer obj strLayer)
)
(if intColor
(vla-Put-Color obj intColor)
)
(if strLtype
(MJ:Apply-Ltype obj strLtype)
)
(vla-Update obj)
(vlax-Release-Object obj)
(entlast)
)
(T (princ "\nUnable to modify object properties..."))
)
)
(T (princ "\nMakeArcEllipse2: Invalid parameter list..."))
)
)
;;57 [功能] 生成一个点
;; 示例: (MJ:AddPoint p1 nil)
(defun MJ:AddPoint (pt strLayer / obj)
(cond
((and pt (listp pt))
(setq obj (vla-addPoint *MS* (vlax-3D-Point pt)))
(if (vlax-Write-Enabled-p obj)
(progn
(if strLayer
(vla-Put-Layer obj strLayer)
)
(vla-Update obj)
(vlax-Release-Object obj)
(entlast)
)
(princ "\nMJ:AddPoint: Unable to modify object!")
)
)
(T (princ "\nMJ:AddPoint: Invalid parameter list..."))
)
)
;;58 [功能] 单行文字
;; 示例: (MJ:AddText "ABC" p1 "MC" "STANDARD" 0.25 1.0 0 "TEXT" nil)
(defun MJ:AddText
(strTxt pt Just strStyle dblHgt
dblWid dblRot strLay intCol/
txtobj
)
(cond
((setq txtobj
(vla-AddText
(MJ:ActiveSpace)
strTxt
(if (not (member (strcase Just) '("A" "F")))
(vlax-3d-Point pt)
(vlax-3d-Point (car pt))
) ; endif
dblHgt
;; ignored if Just = "A" (aligned)
)
)
(vla-put-StyleName txtobj strStyle)
(vla-put-Layer txtobj strLay)
(if intCol
(vla-put-Color txtobj intCol)
)
(setq Just (strcase Just))
;; force to upper case for comparisons...
;; Left/Align/Fit/Center/Middle/Right/BL/BC/BR/ML/MC/MR/TL/TC/TR
;; Note that "Left" is not a normal default.
;;
;; ALIGNMENT TYPES...
;; AcAlignmentLeft=0
;; AcAlignmentCenter=1
;; AcAlignmentRight=2
;; AcAlignmentAligned=3
;; AcAlignmentMiddle=4
;; AcAlignmentFit=5
;; AcAlignmentTopLeft=6
;; AcAlignmentTopCenter=7
;; AcAlignmentTopRight=8
;; AcAlignmentMiddleLeft=9
;; AcAlignmentMiddleCenter=10
;; AcAlignmentMiddleRight=11
;; AcAlignmentBottomLeft=12
;; AcAlignmentBottomCenter=13
;; AcAlignmentBottomRight=14
;;
;; HORIZONTAL JUSTIFICATIONS...
;; AcHorizontalAlignmentLeft=0
;; AcHorizontalAlignmentCenter=1
;; AcHorizontalAlignmentRight=2
;; AcHorizontalAlignmentAligned=3
;; AcHorizontalAlignmentMiddle=4
;; AcHorizontalAlignmentFit=5
;;
;; VERTICAL JUSTIFICATIONS...
;; AcVerticalAlignmentBaseline=0
;; AcVerticalAlignmentBottom=1
;; AcVerticalAlignmentMiddle=2
;; AcVerticalAlignmentTop=3
(cond
((= Just "L")
;; Left
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
((= Just "C")
;; Center
(vla-put-Alignment txtobj 1)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
((= Just "R")
;; Right
(vla-put-Alignment txtobj 2)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
((= Just "A")
;; Alignment
(vla-put-Alignment txtobj 3)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
)
((= Just "M")
;; Middle
(vla-put-Alignment txtobj 4)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
((= Just "F")
;; Fit
(vla-put-Alignment txtobj 5)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
)
((= Just "TL")
;; Top-Left
(vla-put-Alignment txtobj 6)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
((= Just "TC")
;; Top-Center
(vla-put-Alignment txtobj 7)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
((= Just "TR")
;; Top-Right
(vla-put-Alignment txtobj 8)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
((= Just "ML")
;; Middle-Left
(vla-put-Alignment txtobj 9)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
((= Just "MC")
;; Middle-Center
(vla-put-Alignment txtobj 10)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
((= Just "MR")
;; Middle-Right
(vla-put-Alignment txtobj 11)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
((= Just "BL")
;; Bottom-Left
(vla-put-Alignment txtobj 12)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
((= Just "BC")
;; Bottom-Center
(vla-put-Alignment txtobj 13)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
((= Just "BR")
;; Bottom-Right
(vla-put-Alignment txtobj 14)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(vla-put-ScaleFactor txtobj dblWid)
(vla-put-Rotation txtobj (DTR dblRot))
)
)
(vla-Update txtobj)
(vlax-Release-Object txtobj)
(entlast)
)
)
)
;;59 [功能] 画多边形
;; (MJ:AddPolygon center, radius, sides, flag, width, layer, color, ltype)
;; 示例: (MJ:AddPolygon pt1 1.0 6 nil 0 "0" nil "DASHED")
(defun MJ:AddPolygon
(ctrptdblRad intSides strTypedblWid
strLayintCol strLtype / pa
dgptlist deg
)
(setq pa(polar ctrpt 0 dblRad)
dg(/ 360.0 intSides)
;; get angles between faces
deg dg
)
(repeat intSides
(setq ptlist
(if ptlist
(append ptlist (list (polar ctrpt (MJ:D2R deg) dblRad)))
(list (polar ctrpt (MJ:D2R deg) dblRad))
)
)
(setq deg (+ dg deg))
) ; repeat
(MJ:AddPline ptlist strLay T intCol strLtype dblWid)
)
;;60 [功能] 画矩形
;; (MJ:AddRectangle p1(lower left), p3(upper right), layer, color, linetype, width)
;; 示例: (MJ:AddRectangle p1 p3 "0" nil "DASHED" 0.25)
(defun MJ:AddRectangle
(p1 p3 strLayer intColor strLtype dblWid / p2 p4 obj)
(setq p2 (list (car p1) (cadr p3))
p4 (list (car p3) (cadr p1))
)
(cond
((setq obj (MJ:AddPline
(list p1 p2 p3 p4)
strLayer
T
intColor
strLtype
dblWidth
)
)
obj
;; raise object (entity name)
)
)
)
;;61 [功能] 画长方体
;; (MJ:AddSolid points-list, layer(string), color(integer))
;; 示例: (MJ:AddSolid ptlist "0" nil)
(defun MJ:AddSolid (ptlist strLayer intColor / plist obj)
(cond
((and ptlist (listp ptlist) (listp (car ptlist)))
(if (= (length ptlist) 3)
(setq plist (append ptlist (list (last ptlist))))
(setq plist ptlist)
)
(cond
((setq obj (vla-addSolid
(MJ:ActiveSpace)
(vlax-3D-Point (car plist))
(vlax-3D-Point (cadr plist))
(vlax-3D-Point (caddr plist))
(vlax-3D-Point (cadddr plist))
)
)
(if strLayer
(vla-Put-Layer obj strLayer)
)
(if intColor
(vla-Put-Color obj intColor)
)
(vla-Update obj)
(vlax-release-object obj)
(entlast)
) ;
(T (princ "\nUnable to create object..."))
) ; cond
) ;
(T (princ "\nMJ:AddSolid: Invalid parameter list..."))
)
)
;;62 [功能] 多行文字MText
(defun myMText (txtString coner Width)
(vla-addText *MS* (vlax-3d-point pt) Width txtString)
)
;;63 [功能] 面域Region
(defun myRegion (curveObjList nColor / CN CURVES REGIONOBJ)
(setq cn (length curveObjList))
(setq curves (vlax-make-safearray vlax-vbObject (cons 0 (1- cn))))
(vlax-safearray-fill curves curveObjList)
(setq RegionObj (vla-AddRegion *MS* curves))
(vla-put-color
(vla-safearray-get-element (vla-Variant-value RegionObj) 0)
nColor
)
)
;;64 [功能] 对象外画一矩形
;; 示例: (MJ:DrawVpBorder (car (entsel))) ;;
;; Notes: 1. The return value is the entity name of the newly created lwpolyline ;;
;; 2. The layout containing the viewport to be drawn must be active ;;
(defun MJ:DrawVpBorder (vp / ll ur coords pl)
(vl-load-com)
(setq vp (vlax-ename->vla-object vp))
(vla-GetBoundingBox vp 'll 'ur)
(setq ll (vlax-safearray->list ll)
ur (vlax-safearray->list ur)
)
(setq coords (vlax-safearray-fill
(vlax-make-safearray vlax-vbDouble (cons 0 7))
(list (nth 0 ll);x
(nth 1 ll);y
(nth 0 ur);x
(nth 1 ll);y
(nth 0 ur)
(nth 1 ur)
(nth 0 ll)
(nth 1 ur)
)
)
)
(vla-put-closed
(setq pl (vla-AddLightWeightPolyline
(vla-get-ModelSpace (vla-get-Document vp))
coords
)
)
:vlax-true
)
(*Obj2En* pl)
)
;;65.1 [功能] 创建图层(成功返回层名)
;;(MJ:DefineLayer strName intColor strLtype booleCur)
;; 示例: (MJ:DefineLayer "MJ:Layer1" 3 "DASHED" T)
(defun MJ:DefineLayer
(strName intColor strLtype booleCur / iloc obj out)
(cond
((not (tblsearch "layer" strName))
(setq obj (vla-add (*LAYS*) strName))
(setq iloc (vl-position strName (MJ:ListLayers)))
(cond
((vlax-Write-Enabled-p obj)
(if intColor
(vla-put-Color obj intColor)
)
(if strLtype
(MJ:Apply-Ltype obj strLtype)
)
)
(T (princ "\nUnable to modify object properties..."))
)
(if booleCur
(vla-put-ActiveLayer
*DOC*
(vla-Item (*LAYS*) iloc)
)
)
(setq out strName)
)
(T
(princ (strcat "\nLayer already exists: " strName))
)
)
out
)
;;65.2 [功能] 创建一个图层(新建层不为当前层)
;; 示例: (MJ:MakeLayer "A-Wall")
(defun MJ:MakeLayer (lName / oLayer)
(if
(vl-catch-all-error-p
(setq oLayer
(vl-catch-all-apply
'vla-add
(list
*LAYS*
lName
)
)
)
)
nil
oLayer
)
)
;;66.1 [功能] 表->变体数组类型
(defun MJ:DblList->VariantArray (nList / ArraySpace sArray)
;; allocate space for an array of 2d points stored as doubles
(setq ArraySpace
(vlax-Make-SafeArray
vlax-vbDouble
(cons 0
(- (length nList) 1)
)
)
)
(setq sArray (vlax-SafeArray-Fill ArraySpace nList))
(vlax-Make-Variant sArray)
)
;;66.2 [功能] 表->整数数组
(defun MJ:IntList->VarArray (aList)
(vlax-SafeArray-Fill
(vlax-Make-SafeArray
vlax-vbInteger ; (2) Integer
(cons 0 (- (length aList) 1))
)
aList
)
)
;;66.3 [功能] 表->变体数组
(defun MJ:VarList->VarArray (aList)
(vlax-SafeArray-Fill
(vlax-Make-SafeArray
vlax-vbVariant ;(12) Variant
(cons 0 (- (length aList) 1))
)
aList
)
)
;;66.4 [功能] 选择集->数组
(defun SS->Array (ss / c r)
(vl-load-com)
(setq c -1)
(repeat (sslength ss)
(setq r (cons (ssname ss (setq c (1+ c))) r))
)
(setq r (reverse r))
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbObject;根据需要使用其类型
(cons 0 (1- (length r)))
)
(mapcar 'vlax-ename->vla-object r)
)
)
;;66.5 [功能] 列表->变体数组
;; 示例: (setq ptlist (list "1" 2 (list 1.0 2.0 3.0)))
;;(MJ:list->VariantArray (apply 'append ptlist) vlax-vbDouble)
;; Notes: 1. If your list includes various data types, pass vlax-vbVariant for the
;; varType argument
;; 2. Entity names are converted to ObjectIDs
;; 3. To convert a point list to ActiveX coordinates:
(defun MJ:list->VariantArray (lst varType)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
varType
(cons 0 (1- (length lst)))
)
(mapcar
'(lambda (x)
(cond
((= (type x) 'list)
(vlax-safearray-fill
(vlax-make-safearray
(if (apply '= (mapcar 'type x))
(cond
((= (type (car x)) 'REAL) vlax-vbDouble)
((= (type (car x)) 'INT) vlax-vbInteger)
((= (type (car x)) 'STR) vlax-vbString)
)
vlax-vbVariant
)
(cons 0 (1- (length x)))
)
x
)
)
((= (type x) 'ename)
(vla-get-objectid (*En2Obj* x))
)
(t x)
)
)
lst
)
)
)
)
;;67 [功能] 对象端点列表
;; 示例:(MJ:GetEllipseArcPoints (car (entsel)))返回两端点
(defun MJ:GetEllipseArcPoints
(ellent / OUT P-END P-START VLAOBJECT-ELLIPSE)
(setq vlaObject-Ellipse (MJ:MakeObject ellent)
;; convert ename to object
p-start (vla-Get-StartPoint vlaObject-Ellipse)
p-end (vla-Get-EndPoint vlaObject-Ellipse)
out (list
(vlax-SafeArray->List (vlax-Variant-Value p-start))
(vlax-SafeArray->List (vlax-Variant-Value p-end))
)
)
out
)
;;68 [功能] 更改Vla对象线型比例
;; 示例: (MJ:Apply-LtScale objLine 24.0)
(defun MJ:Apply-LtScale (obj dblLtScale)
(cond
((and
(vlax-Read-Enabled-p obj)
(vlax-Write-Enabled-p obj)
)
(vla-Put-Linetype dblLtScale)
T
)
(T (princ "\n Unable to modify object!"))
)
)
;;69 [功能] 将图层集合中的第一个图层设置为当前层
(defun MJ:LayZero ()
(vla-put-ActiveLayer
*DOC*
(vla-Item (*LAYS*) 0)
)
)
;;70 [功能] 设置指定层为当前层
;; (MJ:LayActive "DIM")相当于(command "clayer" "DIM")
(defun MJ:LayActive (name / iloc out)
(cond
((and
(tblsearch "layer" name)
(setq iloc (vl-Position name (MJ:ListLayers)))
)
(vla-put-ActiveLayer
*DOC*
(vla-Item (*LAYS*) iloc)
)
(setq out name)
)
(T (princ (strcat "\n Layer not defined: " name)))
)
out
)
;;71.1图层列表 开
(defun MJ:LayerOn (LayList)
(vlax-for each (vla-get-layers *DOC*)
(if (member (strcase (vla-get-name each)) LayList)
(if (vlax-write-enabled-p each)
(vla-put-LayerOn each :vlax-True)
)
)
(vlax-release-object each)
)
)
;;71.2 [功能] 图层列表 关
(defun MJ:LayerOff (LayList)
(vlax-for each (*LAYS*)
(if (member (strcase (vla-get-name each)) LayList)
(if (vlax-write-enabled-p each)
(vla-put-LayerOn each :vlax-False)
)
)
(vlax-release-object each)
)
)
;;71.3 [功能] 图层列表 冻结
(defun MJ:LayerFreeze (LayList)
(vlax-for each (*LAYS*)
(if (member (strcase (vla-get-name each)) LayList)
(if (vlax-write-enabled-p each)
(vla-put-Freeze each :vlax-True)
)
)
(vlax-release-object each)
)
)
;;71.4 [功能] 图层列表 解冻
(defun MJ:LayerThaw (LayList)
(vlax-for each (*LAYS*)
(if (member (strcase (vla-get-name each)) LayList)
(if (vlax-write-enabled-p each)
(vla-put-Freeze each :vlax-False)
)
)
(vlax-release-object each)
)
)
;;71.5 [功能] 图层列表[打印/不打印]
;; 示例: (MJ:LayerNoPlot '("DOORS" "WINDOWS") T)设置图层不打印
;; 示例: (MJ:LayerNoPlot '("DOORS" "WINDOWS") nil) 设置图层打印
(defun MJ:LayerNoPlot (LayList On-Off)
(vlax-for each (*LAYS*)
(if (member (strcase (vla-get-name each)) LayList)
(if (vlax-write-enabled-p each)
(if On-Off
(vla-put-Plottable each :vlax-True)
(vla-put-Plottable each :vlax-False)
)
)
)
(vlax-release-object each)
)
)
;;71.6 [功能] 图层列表 锁
(defun MJ:LayerLock (LayList)
(vlax-for each (*LAYS*)
(if (member (strcase (vla-get-name each)) LayList)
(if (vlax-write-enabled-p each)
(vla-put-Lock each :vlax-True)
)
)
(vlax-release-object each)
)
)
;;71.7 [功能] 图层列表 解锁
(defun MJ:LayerUnLock (LayList)
(vlax-for each (*LAYS*)
(if (member (strcase (vla-get-name each)) LayList)
(if (vlax-write-enabled-p each)
(vla-put-Lock each :vlax-False)
)
)
(vlax-release-object each)
)
)
;;71.8 [功能] 锁定图层列表
(defun MJ:ListLayers-Locked (/ each out)
(vlax-for each (*LAYS*)
(if (= (vlax-get-property each "Lock") :vlax-true)
(setq out (cons (vla-get-name each) out))
)
)
out
)
;;71.9 [功能] 返回冻结图层列表
(defun MJ:ListLayers-Frozen (/ each out)
(vlax-for each (*LAYS*)
(if (= (vlax-get-property each "Freeze") :vlax-true)
(setq out (cons (vla-get-name each) out))
)
)
out
)
;;71.10 [功能] 返回关闭图层列表
(defun MJ:ListLayers-Off (/ each out)
(vlax-for each (*LAYS*)
(if (= (vlax-get-property each "LayerOn") :vlax-false)
(setq out (cons (vla-get-name each) out))
)
)
out
)
;;71.11 [功能] 可打印图层列表
(defun MJ:ListLayers-Plottable (/ each out)
(vlax-for each (*LAYS*)
(if (= (vlax-get-property each "Plottable") :vlax-true)
(setq out (cons (vla-get-name each) out))
)
)
out
)
;;71.12 [功能] 非打印图层列表
(defun MJ:ListLayers-Plottalbe-Not (/ each out)
(vlax-for each (*LAYS*)
(if (= (vlax-get-property each "Plottable") :vlax-false)
(setq out (cons (vla-get-name each) out))
)
)
out
)
;;71.13 [功能] 层是否冻结？
;;(MJ:Layer-Frozen-p "DIM")
(defun MJ:Layer-Frozen-p (lname / each)
(if
(and
(setq fl (MJ:ListLayers-Frozen))
;; any frozen layers?
(member (strcase lname) (mapcar 'strcase fl))
)
T
)
)
;;71.14 [功能] 解冻 解锁 开 所有图层
(defun MJ:Mylayer ()
(acet-layerp-mark nil)
(acet-layerp-mode T)
(acet-layerp-mark T)
(command "_.Layer" "Thaw" "*" "U" "*" "ON" "*" "")
)
;;71.15 [功能] 恢复图层状态By coaying
(defun MJ:layer-restore ()
(acet-layerp-mark nil)
(command "_.layerp")
)
;;71.16 [功能] 得到图层状态highflybird
(defun Get_Layer_Status (/ V_LIST L_LIST C_LIST T_LIST W_LIST *DOC)
(setq *Doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(vlax-for n (vla-get-layers *DOC)
(setq V_List (cons (cons n (vla-get-LayerOn n)) V_List)
L_List (cons (cons n (vla-get-Lock n)) L_List)
C_List (cons (cons n (vla-get-TrueColor n)) C_List)
T_List (cons (cons n (vla-get-Linetype n)) T_List)
W_List (cons (cons n (vla-get-LineWeight n)) W_List)
F_List (cons (cons n (vla-get-Freeze n)) F_List)
)
)
(List V_List L_List C_List T_List W_List F_List)
)
;;71.17 [功能] 恢复图层状态highflybird
(defun Restore_Layer_status (LayLst)
(mapcar (function
(lambda (x y)
(foreach n X
(if (/= (strcase (setq name (vla-get-name (car n))))
(strcase (getvar "clayer"))
) ; 非当前层
(vlax-put-property (car n) y (cdr n))
;;对于当前层
(if (/= y "Freeze") ; 排除冻结操作，以防出错
(vlax-put-property (car n) y (cdr n))
)
)
)
)
)
LayLst
(list "Layeron" "Lock" "TrueColor"
"LineType" "LineWeight" "Freeze"
)
)
;;(vl-cmdf "regen")
)
;;71.18 [功能] 图层是否锁定?
;;(b_layer_locked "0"),0层锁后返回T
(defun b_layer_locked (la / na e1)
(setq na (tblobjname "layer" la)
e1 (entget na)
)
(equal 4 (logand 4 (cdr (assoc 70 e1))))
)
;;72 [功能] 设置vla对象线宽
;; NOTES:
;; "ByLwDefault" = -3
;; "ByBlock" = -2
;; "ByLayer" = -1
;; Other values are 0, 5, 9, 13, 15, 18, 20, 25, 30, 35, 40, 50, 53, 60,
;; 70, 80, 90, 100, 106, 120, 140, 158, 200, 211
(defun MJ:SetLweight (obj intLwt)
(cond
((member intLwt
'(0 59 13 15 18 20 25 30 3540
50 6070 80 90 100106120140158200
211
)
)
(vla-put-LineWeight obj ineLwt)
T
)
)
)
;;73 [功能] vla选择集是否存在
(defun MJ:SSetExists-p (Name)
(not
(vl-Catch-All-Error-p
(vl-Catch-All-Apply
'vla-Item
(list (vla-Get-SelectionSets *DOC*) Name)
)
)
)
)
;;74.1 [功能] 返回指定类型的选择集
;; 示例: (setq MJ:set (MJ:SelectByType "CIRCLE"))
;;(MJ:MapCollection MJ:set 'MJ:DeleteObject)圆全部删除
(defun MJ:SelectByType (objtype / ss)
(if (MJ:SSetExists-p "%TEMP_SET")
(vla-Delete
(vla-Item
(vla-get-SelectionSets *DOC*)
"%TEMP_SET"
)
)
)
(setq ss
(vla-Add
(vla-get-SelectionSets *DOC*)
"%TEMP_SET"
)
)
(vla-Select
ss
ACSelectionSetAll
nil
nil
(MJ:IntList->VarArray (list 0))
(MJ:VarList->VarArray (list objtype))
)
ss
)
;;74.2 [功能] 返回指定类型的选择集
;; MODULE: (MJ:SelectOnScreen-Filter GroupCodes FilterLists)
;;示例见下
(defun MJ:SelectOnScreen-Filter (GroupCodes FilterLists / ss)
(if (MJ:SSetExists-p "%TEMP_SET")
(vla-Delete
(vla-Item
(vla-get-SelectionSets *DOC*)
"%TEMP_SET"
)
)
)
(setq ss
(vla-Add
(vla-get-SelectionSets *DOC*)
"%TEMP_SET"
)
)
(vla-Select
ss
ACSelectionSetAll
nil
nil
(MJ:IntList->VarArray GroupCodes)
(MJ:VarList->VarArray FilterLists)
)
ss
)
;;74.3 [功能] 返回0层上的圆选择集
(defun MJ:PICKCIRCLES (/ SS)
(if
(setq ss (MJ:SelectOnScreen-Filter '(0 8) '("CIRCLE" "0")))
(vlax-For item ss
(princ (vla-get-ObjectName item))
(terpri)
)
)
(terpri)
ss
)
;;74.4 [功能] 返回圆选择集(并打印名称)
(defun C:GETCIRCLES ()
(if (setq ss (MJ:SelectByType "CIRCLE"))
(vlax-For item ss
(princ (vla-get-ObjectName item))
(terpri)
)
)
ss
)
;;75.1 [功能] 返回CAD窗口状态
;; acEnum 1=Min 2=Normal 3=Max
;; 示例: (MJ:GetWindowState) return 1, 2 or 3
(defun MJ:GetWindowState ()
(vla-get-WindowState *ACAD*)
)
;;75.2 [功能] 设置CAD窗口状态
;; 示例: (MJ:SetWindowState 3) maximizes the window display
(defun MJ:SetWindowState (acEnum)
(vla-put-WindowState *ACAD* acEnum)
)
;;76.1 [功能] 隐藏CAD
;; 示例: (MJ:HideAutoCAD)
(defun MJ:HideAutoCAD ()
(vla-put-Visible *ACAD* :vlax-False)
)
;;76.2 [功能] 显示CAD
;; 示例: (MJ:ShowAutoCAD)
(defun MJ:ShowAutoCAD ()
(vla-put-Visible *ACAD* :vlax-True)
)
;;76.3 [功能] 隐藏CAD一段时间
;; 示例: (MJ:HideShowTest 500) 隐藏CAD，时间500毫秒
(defun MJ:HideShowTest (delay-time)
(MJ:HideAutoCAD)
(vl-cmdf "delay" delay-time)
(MJ:ShowAutoCAD)
)
;;77.1 [功能] CAD参数选择
(defun MJ:DocPrefs ()
(vla-get-Preferences *DOC*)
)
;;77.2 [功能] 线宽显示
(defun MJ:LWdisplayON ()
(vla-put-LineWeightDisplay (MJ:DocPrefs) :vlax-True)
)
;;77.3 [功能] 隐藏线宽
(defun MJ:LWdisplayOFF ()
(vla-put-LineWeightDisplay (MJ:DocPrefs) :vlax-False)
)
;;77.4 [功能] 对象捕捉开
(defun MJ:ObjectSortBySnapON ()
(vla-put-ObjectSortBySnap (MJ:DocPrefs) :vlax-True)
)
;;77.5 [功能] 对象捕捉关闭
(defun MJ:ObjectSortBySnapOFF ()
(vla-put-ObjectSortBySnap (MJ:DocPrefs) :vlax-False)
)
;;77.6[功能] 图形被其它用户参照时仍可以立即编辑
(defun MJ:XrefEditON ()
(vla-put-XrefEdit (MJ:DocPrefs) :vlax-True)
)
;;77.7[功能] 图形被其它用户参照时不可以立即编辑
(defun MJ:XrefEditOFF ()
(vla-put-XrefEdit (MJ:DocPrefs) :vlax-False)
)
;;78.1 [功能] CAD菜单集合
(defun MJ:MenuGroups ()
(vla-get-menugroups *ACAD*)
)
;;78.2 [功能] 菜单列表
;;示例("ACAD" "CXinZhi")
(defun MJ:MenuGroups-ListAll (/ out)
(vlax-for each (MJ:MenuGroups)
(setq out (cons (vla-get-name each) out))
)
(reverse out)
)
;;78.3 [功能] 菜单是否存在
;;示例(MJ:MenuGroup-Exists-p "CXinZhi")返回 1
(defun MJ:MenuGroup-Exists-p (name)
(if
(member
(strcase name)
(mapcar 'strcase (MJ:MenuGroups-ListAll))
)
(vl-position name (MJ:MenuGroups-ListAll))
)
)
;;78.4 [功能] 工具条Vla集合
(defun MJ:Toolbars (mgroup)
(if (MJ:MenuGroup-Exists-p mgroup)
(vla-get-toolbars
(vla-item
(MJ:MenuGroups)
(vl-position
(strcase mgroup)
(mapcar 'strcase (MJ:MenuGroups-ListAll))
)
)
)
)
)
;;78.5 [功能] 工具条列表
;;(MJ:ToolbarsList "CXinZhi")返回("附加图层工具" "附加文字工具" "附加标准工具")
(defun MJ:ToolbarsList (mgroup / tb out)
(if (setq tb (MJ:Toolbars mgroup))
(vlax-for each tb
(setq out (cons (vla-get-name each) out))
)
)
(reverse out)
)
;;78.6 [功能] 工具条列表
;; Arguments: 菜单名称
;; 示例: (ListToolbars "acad")(ListToolbars "CXinZhi")
(defun MJ:ListToolbars (groupName / mGroups mGroup lst)
(if (not
(vl-catch-all-error-p
(setq
mGroup (vl-catch-all-apply
'vla-item
(list (vla-get-menugroups *ACAD*)
groupName
)
)
)
)
)
(vlax-for tBar (vla-get-toolbars mGroup)
(setq lst (cons (vla-get-name tBar) lst))
)
)
)
;;78.7 [功能] 工具条是否存在
;;(MJ:Toolbar-Exists-p "CXinZhi" "附加图层工具");返回0
(defun MJ:Toolbar-Exists-p (mgroup tbname)
(if
(and
(MJ:MenuGroup-Exists-p mgroup)
(member
(strcase tbname)
(mapcar 'strcase (MJ:Toolbars-ListAll mgroup))
)
)
(vl-position tbname (MJ:Toolbars-ListAll mgroup))
)
)
;;78.8 [功能] 指定工具条(Vla)
(defun MJ:Toolbar (mgroup tbname / loc)
(if (setq loc (MJ:Toolbar-Exists-p mgroup tbname))
(vla-item (MJ:Toolbars mgroup) loc)
)
)
;;78.9 [功能] 显示指定工具条
;;(MJ:Toolbar-Show "ACAD" "UCS")将显示UCS工具条
;;(MJ:Toolbar-Show "CXinZhi" "附加图层工具")
(defun MJ:Toolbar-Show (mgroup tbname / tb)
(if (setq tb (MJ:Toolbar mgroup tbname))
(if (= (vla-get-visible tb) :vlax-false)
(progn
(vla-put-visible tb :vlax-true)
T
)
)
)
)
;;78.10 [功能] 隐藏工具条
(defun MJ:Toolbar-Hide (mgroup tbname / tb)
(if (setq tb (MJ:Toolbar mgroup tbname))
(if (= (vla-get-visible tb) :vlax-true)
(progn
(vla-put-visible tb :vlax-false)
T
)
)
)
)
;;78.11 [功能] 工具条放置位置
;; NOTES: Allowable <dock> values are 0(top), 1(bottom), 2(left), ;;
;; and 3(right). Returns 1 if successful, -1 if toolbar is not ;;
;; visible, -2 if parameter is invalid, or 0 if toolbar not found. ;;
(defun MJ:Toolbar-Dock (mgroup tbname dock / tb)
(if (setq tb (MJ:Toolbar mgroup tbname))
(if (= (vla-get-visible tb) :vlax-true)
(if (member dock '(0 1 2 3))
(progn
(vlax-invoke-method tb 'Dock dock)
1
)
-2
;; invalid dockstatus parameter
)
-1
;; toolbar not visible
)
0
;; toolbar not found
)
)
;;78.12 [功能] Float a given toolbar at specified position(top and left)
;; and display with specified number of rows. Returns 1 if successful,
;; -1 if toolbar is not visible, 0 if toolbar is not found.
(defun MJ:Toolbar-Folat (mgroup tbname top left rows)
(if (setq tb (MJ:Toolbar mgroup tbname))
(if (= (vla-get-visible tb) :vlax-true)
(progn
(vlax-invoke-method tb 'Float top left rows)
1
)
-1
;; toolbar not visible
)
0
;; toolbar not found
)
)
;;78.13 [功能] 改变工具条按钮位图
;; 示例: (MJ:ChangeBitmap "acad" "dimension" "linear dimension" "test.bmp")
;; Notes: 1. If the bitmap is not in the AutoCAD search path, you must specify ;;
;; the full path to file ;;
(defun MJ:ChangeBitmap (mnuGroup tbrName btnName bitmap)
(vl-load-com)
(vla-setbitmaps
(vla-item
(vla-item
(vla-get-toolbars
(vla-item (vla-get-menugroups *ACAD*)
mnuGroup
)
)
tbrName
)
btnName
)
bitmap
bitmap
)
(princ)
)
;;79 [功能] 2D点转成vla 2D
(defun MJ:2DPoint (pt)
(vl-load-com)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble '(0 . 1))
(list (car pt) (cadr pt))
)
)
)
;;80.1 [功能] 激活最左边一个布局
;;下面程序使用vla-activate有问题,看起来没有错误
;;模型和布局之间自由切换(setvar "CTAB" "layout2")
(defun MJ:ActivateLastLayout (/ CNT I)
(vlax-for layout *LOUTS*
(if (= (vla-get-taborder layout) 1);取得布局的tab顺序,图纸空间的标签（tab）顺序必须是1或大于1
(vla-put-ActiveLayout *DOC* layout) ; (vla-activate layout)运行有问题
)
)
)
;;80.2 [功能] 激活第二个图形 见10
(defun MJ:ActivateDrawing ()
(vla-activate (vla-item *docs* 1))
)
申明:本贴引来你们争吵,还有喊冤的,是我没有想到的.
至于收取明经币,纯粹是针对那些潜水员的。有些潜水员只下载，从来不在明经上放点有用的东西。
用highflybird的话说，明经币算什么？
本贴只是为了我自己编程时方便而收集的，打包发出来，是想方便自己也方便别人的想法,仅只而已。 自贡黄明儒 发表于 2012-11-22 09:55
;;28.2 [功能] 删除未使用的图层,比purge彻底
(defun MJ:LayerDelete ()
(vl-Load-Com)
加载2是什么意思，加载哪一个呢？ 既然是收集，建议还是免币下载吧 板凳啊！ 感谢楼主分享,学习了! 感谢楼主分享.......... 支持一下，收集辛苦了 加油啊， 继续............ 支持支持！ 非常之感谢 哥 你要什么你说 才100多个就算多了……