常用函数.lsp

自贡黄明儒 · 发表于 2012-9-20 16:23:46

本帖最后由自贡黄明儒于 2022-5-16 13:53 编辑

;;各位，把你们收藏都拿出秀一秀呀，放在箱底会生霉的
;;我的收集是在caoyin发布的通用函数基础上扩展的----自贡黄明儒 2012.9.20
;;有人说,抄一个人的叫偷,抄多个人的叫做研究,如果这种说话真的成立的话,那么我是在进行研究

;;1 [功能] 检查加载vlisp扩展
;;2 常数(lisp编辑器在输出局部变量时,带*的会排在前面.Caoyin这样写很有道理)
;;3 [功能] 返回活动空间vla对象
;;4.1 [功能] 返回当前活动空间名称("Model" or "

aper")
;;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 命令“引线设置”对话框的相关参数
;;注：引线的箭头跟DIMSTYLE使用同一设置，可以直接修改DIMLDRBLK系统变量
;;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);;-----注释-〉注释类型[0,1,2,3,4]
(61 . 0);;-----注释-〉重复使用注释[0,1,2]
(62 . 1);;-----附着-〉文字在右边[0,1,2,3,4]
(63 . 1);;-----附着-〉文字在左边[0,1,2,3,4]
(64 . 0);;-----附着-〉最后一行加下划线[0,1]
(65 . 0);;-----引线和箭头-〉引线[0,1]
(66 . 0);;-----引线和箭头-〉点数-〉无限制[0,1]
(67 . 3);;-----引线和箭头-〉点数[任意正整数]
(68 . 1);;-----注释-〉多行文字选项-〉提示输入宽度[0,1]
(69 . 0);;-----注释-〉多行文字选项-〉始终左对齐[0,1]
(70 . 0);;-----引线和箭头-〉角度约束->第一段[0,1,2,3,4,5]
(71 . 0);;-----引线和箭头-〉角度约束->第二段[0,1,2,3,4,5]
(72 . 0);;-----注释-〉多行文字选项-〉文字边框[0,1]
(40 . 0.0)
(170 . 2);;----控制“引线设置”对话框的缺省选项卡[0,1,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" source target)用一个对象的图层等修改另一个对象的图层等
(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:AddPline ptlist "0" T 3 "DASHED" 0.125) ;;
(defun MJ:AddPline
(ptlist strLayer Bclosed intColor strLtype
dblWidth / vrtcs lst plgen
plist plpoints obj
)
(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
(ctrpt dblRad intSides strType dblWid
strLay intCol strLtype / pa
dg ptlist 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 5 9 13 15 18 20 25 30 35 40
50 60 70 80 90 100 106 120 140 158 200
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 [功能] 激活第二个图形[Ctrl+Tab] 见10
(defun MJ:ActivateDrawing ()
(vla-activate (vla-item *docs* 1))
)

;;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 命令“引线设置”对话框的相关参数 
;;注：引线的箭头跟DIMSTYLE使用同一设置，可以直接修改DIMLDRBLK系统变量 
;;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);;-----注释-〉注释类型[0,1,2,3,4] 
                        (61 . 0);;-----注释-〉重复使用注释[0,1,2] 
                        (62 . 1);;-----附着-〉文字在右边[0,1,2,3,4] 
                        (63 . 1);;-----附着-〉文字在左边[0,1,2,3,4] 
                        (64 . 0);;-----附着-〉最后一行加下划线[0,1] 
                        (65 . 0);;-----引线和箭头-〉引线[0,1] 
                        (66 . 0);;-----引线和箭头-〉点数-〉无限制[0,1] 
                        (67 . 3);;-----引线和箭头-〉点数[任意正整数] 
                        (68 . 1);;-----注释-〉多行文字选项-〉提示输入宽度[0,1] 
                        (69 . 0);;-----注释-〉多行文字选项-〉始终左对齐[0,1] 
                        (70 . 0);;-----引线和箭头-〉角度约束->第一段[0,1,2,3,4,5] 
                        (71 . 0);;-----引线和箭头-〉角度约束->第二段[0,1,2,3,4,5] 
                        (72 . 0);;-----注释-〉多行文字选项-〉文字边框[0,1] 
                        (40 . 0.0) 
                        (170 . 2);;----控制“引线设置”对话框的缺省选项卡[0,1,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" source  target)用一个对象的图层等修改另一个对象的图层等 
(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:AddPline  ptlist "0" T 3 "DASHED" 0.125)   ;; 
(defun MJ:AddPline 
       (ptlist strLayer  Bclosed   intColor  strLtype 
        dblWidth /   vrtcs     lst       plgen 
        plist plpoints  obj 
       ) 
  (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 
         (ctrpt  dblRad   intSides strType  dblWid 
   strLay  intCol   strLtype /     pa 
   dg  ptlist   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    5  9    13   15 18   20   25   30   35  40 
        50   60  70   80   90 100  106  120  140  158  200 
        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 [功能] 激活第二个图形[Ctrl+Tab] 见10 
(defun MJ:ActivateDrawing ()   
  (vla-activate (vla-item *docs* 1)) 
)

自贡黄明儒 · 发表于 2012-9-25 10:12:26

申明:本贴引来你们争吵,还有喊冤的,是我没有想到的.
至于收取明经币,纯粹是针对那些潜水员的。有些潜水员只下载，从来不在明经上放点有用的东西。
用highflybird的话说，明经币算什么？
本贴只是为了我自己编程时方便而收集的，打包发出来，是想方便自己也方便别人的想法,仅只而已。

墙脚哥 · 发表于 2016-7-22 01:57:25

自贡黄明儒发表于 2012-11-22 09:55
;;28.2 [功能] 删除未使用的图层,比purge彻底
(defun MJ:LayerDelete ()
(vl-Load-Com)

加载2是什么意思，加载哪一个呢？

e2002 · 发表于 2012-9-20 16:33:21

既然是收集，建议还是免币下载吧

lty · 发表于 2012-9-20 16:39:22

板凳啊！

yoyoho · 发表于 2012-9-20 16:44:15

感谢楼主分享,学习了!

穿靴子的猫 · 发表于 2012-9-20 16:54:33

感谢楼主分享..........

yjr111 · 发表于 2012-9-20 17:15:25

支持一下，收集辛苦了

652758365 · 发表于 2012-9-20 18:07:31

加油啊，继续............

smartstar · 发表于 2012-9-20 18:07:38

支持支持！

巛丸 · 发表于 2012-9-20 18:36:01

非常之感谢哥你要什么你说

xyp1964 · 发表于 2012-9-20 18:47:14

才100多个就算多了……

账号		自动登录	找回密码
密码			注册

[函数] 常用函数.lsp

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐:

点评

点评