常用函数.lsp

自贡黄明儒

;;各位，把你们收藏都拿出秀一秀呀，放在箱底会生霉的
;;我的收集是在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 [功能] 局部更新

2. 
   
3. ;;1 [功能] 检查加载vlisp扩展
   
4. (vl-Load-COM)
   
5. ;;2  常数(lisp编辑器在输出局部变量时,带*的会排在前面.Caoyin这样写很有道理)
   
6. (setq *En2Obj*  vlax-ename->vla-object
   
7.       *Obj2En*  vlax-vla-object->ename
   
8.       *2PI*     (* PI 2)
   
9.       *0.5PI*   (/ PI 2)
   
10.       *0.25PI*  (/ PI 4)
    
11.       ;;常用VLA对象、集合
    
12.       *ACAD*  (vlax-get-acad-object)
    
13.       *DOC*   (vla-get-ActiveDocument *ACAD*)
    
14.       *DOCS*  (vla-get-Documents *ACAD*)
    
15.       *MS*    (vla-get-modelSpace *DOC*)
    
16.       *PS*    (vla-get-paperSpace *DOC*)
    
17.       *BLKS*  (vla-get-Blocks *DOC*)
    
18.       *LAYS*  (vla-get-Layers *DOC*)
    
19.       *LTS*   (vla-get-Linetypes *DOC*)
    
20.       *STS*   (vla-get-TextStyles *DOC*)
    
21.       *GRPS*  (vla-get-groups *DOC*)
    
22.       *DIMS*  (vla-get-DimStyles *DOC*)
    
23.       *LOUTS* (vla-get-Layouts *DOC*)
    
24.       *VPS*   (vla-get-Viewports *DOC*)
    
25.       *VS*    (vla-get-Views *DOC*)
    
26.       *DICS*  (vla-get-Dictionaries *DOC*)
    
27.       ;;常用的几个外部接口对象
    
28.       *FSO*   (vlax-get-or-create-object "Scripting.FileSystemObject")
    
29.       *WSH*   (vlax-get-or-create-object "wscript.shell")
    
30.       *SHELL* (vlax-get-or-create-object "Shell.Application")
    
31.       *SCR*   (vlax-get-or-create-object "ScriptControl")
    
32.       *WBEM*  (vlax-get-or-create-object "WbemScripting.SWbemLocator")
    
33. )
    
34. ;;3 [功能] 返回活动空间vla对象
    
35. (defun MJ:ActiveSpace()
    
36.   (if (= 1 (vlax-get-Property DOC* 'ActiveSpace));模型1,布局0
    
37.     *MS*
    
38.     *PS*
    
39.   )
    
40. )
    
41. ;;4.1 [功能] 返回当前活动空间名称("Model" or "Paper")
    
42. (defun MJ:ActiveSpace-Name ()
    
43.   (if (= 1 (vla-get-ActiveSpace *DOC*))
    
44.     "Model"
    
45.     "Paper"
    
46.   )
    
47. )
    
48. ;;4.2 [功能] 返回空间名称,如"Model"或者"Layout1"...
    
49. (defun MJ:ActiveSpace1 ()
    
50.   (vla-get-Name (vla-get-ActiveLayout *DOC*))
    
51. )
    
52. ;;5 [功能] 返回Preferences vla对象
    
53. (defun MJ:AcadPrefs ()
    
54.   (vlax-Get-Property *ACAD* 'Preferences)
    
55. )
    
56. ;;6 [功能] 返回指定引用的属性
    
57. ;;TabName:Application,Display,Drafting,Files,OpenSave,Output,Profiles,Selection,System,User
    
58. ;; 示例   (MJ:GetPrefKey 'Files 'SupportPath)  获取支持文件路径
    
59. (defun MJ:GetPrefKey (TabName KeyName)
    
60.   (vlax-get-property
    
61.     (vlax-get-property
    
62.       (MJ:AcadPrefs)
    
63.       TabName
    
64.     )
    
65.     KeyName
    
66.   )
    
67. )
    
68. ;;7 [功能] 更改引用设置
    
69. ;; 示例 (MJ:SetPrefKey "OpenSave" "IncrementalSavePercent" 0)
    
70. (defun MJ:SetPrefKey (TabName KeyName NewVal)
    
71.   (vlax-put-property
    
72.     (vlax-get-property
    
73.       (MJ:AcadPrefs)
    
74.       TabName
    
75.     )
    
76.     KeyName
    
77.     NewVal
    
78.   )
    
79. )
    
80. ;;8 [功能] 返回 acad对象的属性
    
81. ;;PropName:ActiveDocument,Application,Caption,Documents,FullName,Height,HWND,LocaleId,MenuBar,
    
82. ;;MenuGroups,Name,Path,Preferences,StatusId,VBE,Version,Visible,Width,WindowLeft,WindowState,WindowTop
    
83. ;; 示例 (MJ:AcadProp 'FullName)
    
84. (defun MJ:AcadProp (PropName)
    
85.   (vlax-get-property *ACAD* PropName)
    
86. )
    
87. ;;9 [功能] 对象名称
    
88. ;; 示例 (MJ:Name *ACAD*) returns "AutoCAD"
    
89. ;; 示例 (MJ:Name *MS*)返回"*Model_Space"
    
90. (defun MJ:Name (obj)
    
91.   (if (vlax-property-available-p obj 'Name)
    
92.     (vlax-get-property obj 'Name)
    
93.     "<NONE_NAME>"
    
94.   )
    
95. )
    
96. ;;10.1 [功能] 打开文件名列表
    
97. ;;verbose:T,nil
    
98. ;; 示例: (MJ:DocsList T)
    
99. ;; NOTES: Verbose为T时full path+filename ; nil时filenames
    
100. (defun MJ:DocsList (verbose / docname out)  
     
101.   (vlax-for each *DOCS*
     
102.     (if verbose
     
103.       (setq docname
     
104.       (strcat
     
105.         (vlax-get-property each 'Path)
     
106.         "\"
     
107.         (MJ:Name each)
     
108.       )
     
109.       )
     
110.       (setq docname (MJ:Name each))
     
111.     )     
     
112.     (setq out (cons docname out))
     
113.   )
     
114.   (reverse out)
     
115. )
     
116. ;;10.2 [功能] (打开文件 未打开文件)列表
     
117. ;;示例(car (MJ:DocsList1 DwgFileLst))取得列表文件中打开的文件列表
     
118. (defun MJ:DocsList1 (DwgFileLst / OPENFILELST)
     
119.   (setq OpenFileLst (vl-remove-if 'VL-FILE-SYSTIME DwgFileLst)
     
120. DwgFileLst  (vl-remove-if-not 'VL-FILE-SYSTIME DwgFileLst)
     
121.   )
     
122.   (if DwgFileLst
     
123.     (setq DwgFileLst (vl-sort DwgFileLst '<))
     
124.   )
     
125.   (if OpenFileLst
     
126.     (setq OpenFileLst (vl-sort OpenFileLst '<))
     
127.   )
     
128.   (list OpenFileLst DwgFileLst)
     
129. )
     
130. ;;11 [功能] 查询对象属性和方法
     
131. (defun C:HHDump (/ ent)
     
132.   (while (setq ent (entsel))
     
133.     (vlax-Dump-Object
     
134.       (vlax-Ename->Vla-Object (car ent))
     
135.     )
     
136.   )
     
137.   (princ)
     
138. )
     
139. ;;12 [功能] 设置 Qleader 命令“引线设置”对话框的相关参数
     
140. ;;注：<font color="red">引线的箭头跟DIMSTYLE使用同一设置，可以直接修改DIMLDRBLK系统变量</font>
     
141. ;;2011.5.5 by caoyin
     
142. (defun QleaderSet (/ DICEN)
     
143.   (setq DICEN (namedobjdict));(enget DICEN)可查看内容(3 . 词典)
     
144.   (if (dictsearch DICEN "AcadDim")
     
145.     (dictremove DICEN "AcadDim")
     
146.   )
     
147.   (dictadd DICEN
     
148.            "AcadDim"
     
149.             (entmakex '((0 . "XRECORD")
     
150.                         (100 . "AcDbXrecord")
     
151.                         (280 . 1)
     
152.                         (90 . 990106)
     
153.                         (3 . "");;-----引线和箭头-〉箭头[用户箭头的缺省块名，""则表示未设置]
     
154.                         (60 . 0);;-----注释-〉注释类型[0,1,2,3,4]
     
155.                         (61 . 0);;-----注释-〉重复使用注释[0,1,2]
     
156.                         (62 . 1);;-----附着-〉文字在右边[0,1,2,3,4]
     
157.                         (63 . 1);;-----附着-〉文字在左边[0,1,2,3,4]
     
158.                         (64 . 0);;-----附着-〉最后一行加下划线[0,1]
     
159.                         (65 . 0);;-----引线和箭头-〉引线[0,1]
     
160.                         (66 . 0);;-----引线和箭头-〉点数-〉无限制[0,1]
     
161.                         (67 . 3);;-----引线和箭头-〉点数[任意正整数]
     
162.                         (68 . 1);;-----注释-〉多行文字选项-〉提示输入宽度[0,1]
     
163.                         (69 . 0);;-----注释-〉多行文字选项-〉始终左对齐[0,1]
     
164.                         (70 . 0);;-----引线和箭头-〉角度约束->第一段[0,1,2,3,4,5]
     
165.                         (71 . 0);;-----引线和箭头-〉角度约束->第二段[0,1,2,3,4,5]
     
166.                         (72 . 0);;-----注释-〉多行文字选项-〉文字边框[0,1]
     
167.                         (40 . 0.0)
     
168.                         (170 . 2);;----控制“引线设置”对话框的缺省选项卡[0,1,2]
     
169.                      ;; (340 . 图元名)
     
170.                      ;;-----当DXF组码60的值为3，且已经设定了块参照的块名，则340组码才会出现
     
171.                      ;;-----格式为(340 . 上次使用块参照作为注释对象，实际插入的块实例的图元名)
     
172.                       )
     
173.               )
     
174.     )
     
175. )
     
176. ;;13 [功能] 求点集中最远，最近点表   ;By 无痕
     
177. ;:(最远两点 最近两点)
     
178. ;;示例(MJ:lensort (while (setq pt(getpoint)) (setq plst (cons pt plst)))))
     
179. ;;(((14857.8 -599.932 0.0) (26695.2 -3687.68 0.0)) ((15733.8 -3687.68 0.0) (15630.7 -3842.07 0.0)))
     
180. (defun MJ:lensort (ptlst / pt d maxd mind maxl minl)
     
181.   (setq minl (list (car ptlst) (cadr ptlst))
     
182. maxd 0
     
183. mind (apply 'distance minl)
     
184.   )
     
185.   (while (setq pt    (car ptlst)
     
186.         ptlst (cdr ptlst)
     
187.   )
     
188.     (foreach n ptlst
     
189.       (setq d (distance n pt))
     
190.       (cond ((< maxd d)
     
191.       (setq maxd d
     
192.      maxl (list n pt)
     
193.       )
     
194.      )
     
195.      ((> mind d)
     
196.       (setq mind d
     
197.      minl (list n pt)
     
198.       )
     
199.      )
     
200.       )
     
201.     )
     
202.   )
     
203.   (list maxl minl)
     
204. )
     
205. ;;14.1 [功能] 返回指定集合的数量
     
206. ;; 示例: (MJ:CollectionCount (MJ:GetLayers)))
     
207. (defun MJ:CollectionCount (Collection)
     
208.   (vlax-get-property Collection 'Count)
     
209. )
     
210. ;;14.2 [功能] 返回文档集合的数量
     
211. (defun MJ:DocsCount ()
     
212.   (vlax-get-property *DOCS* 'Count)
     
213. )
     
214. ;;15 [功能] 返回文档指定对象的属性
     
215. ;;Cname: Active,ActiveDimStyle,ActiveLayer,ActiveLayout,ActiveLinetype,ActivePViewport,ActiveSelectionSet,
     
216. ;;ActiveSpace,ActiveTextStyle,ActiveUCS,ActiveViewport,Application,Blocks,Database,Dictionaries,DimStyles,
     
217. ;;ElevationModelSpace,ElevationPaperSpace,FileDependencies,FullName,Groups,Height,HWND,Layers,Layouts,Limits,
     
218. ;;Linetypes,ModelSpace,MSpace, Name,ObjectSnapMode,PaperSpace,Path,PickfirstSelectionSet,Plot,PlotConfigurations,
     
219. ;;Preferences,ReadOnly,RegisteredApplications,Saved,SelectionSets,SummaryInfo,TextStyles,UserCoordinateSystems,Utility,
     
220. ;;Viewports,Views,Width,WindowState,WindowTitle
     
221. ;;示例 (MJ:DocCollection "WindowState")
     
222. (defun MJ:DocCollection (Cname)
     
223.   (vlax-Get-Property *DOC* Cname)
     
224. )
     
225. ;;15.1 [功能] 图层集合
     
226. (defun MJ:GetLayers () (vlax-Get-Property *DOC* 'Layers))
     
227. ;;15.2 [功能] 线型集合
     
228. (defun MJ:GetLtypes () (vlax-Get-Property *DOC* 'Linetypes))
     
229. ;;15.3 [功能] 文字样式集合
     
230. (defun MJ:GetTextStyles () (vlax-Get-Property *DOC* 'TextStyles))
     
231. ;;15.4 [功能] 尺寸样式集合
     
232. (defun MJ:GetDimStyles () (vlax-Get-Property *DOC* 'DimStyles))
     
233. ;;15.5 [功能] 布局集合
     
234. (defun MJ:GetLayouts () (vlax-Get-Property *DOC* 'Layouts))
     
235. ;;15.6 [功能] 词典集合
     
236. (defun MJ:GetDictionaries () (vlax-Get-Property *DOC* 'Dictionaries))
     
237. ;;15.7 [功能] 块集合(不是我们平时绘图时所说的块)
     
238. (defun MJ:GetBlocks () (vlax-Get-Property *DOC* 'Blocks))
     
239. ;;15.8 [功能] 打印配置集合
     
240. (defun MJ:GetPlotConfigs ()(vlax-Get-Property *DOC* 'PlotConfigurations))
     
241. ;;15.9 [功能] 视图集合
     
242. (defun MJ:GetViews () (vlax-Get-Property *DOC* 'Views))
     
243. ;;15.10 [功能] 视口集合
     
244. (defun MJ:GetViewports () (vlax-Get-Property *DOC* 'Viewports))
     
245. ;;15.11 [功能] 组集合
     
246. (defun MJ:GetGroups () (vlax-Get-Property *DOC* 'Groups))
     
247. ;;15.12 [功能] 注册程序集合
     
248. (defun MJ:GetRegApps () (vlax-Get-Property *DOC* 'RegisteredApplications))
     
249. ;;16 [功能] 返回集合成员名称列表
     
250. ;;示例 (MJ:ListCollectionMemberNames (MJ:GetLayers))返回:图层列表("0" "中心线" "文字" "DIM")
     
251. (defun MJ:ListCollectionMemberNames (collection / out)  
     
252.   (vlax-for each collection
     
253.     (setq out (cons (MJ:Name each) out))
     
254.   )
     
255.   (reverse out)
     
256. )
     
257. ;;16.1 [功能] 返回线型集合成员名称列表(常量*LTS*)
     
258. (defun MJ:ListLtypes ()
     
259.   (MJ:ListCollectionMemberNames (vlax-Get-Property *DOC* 'Linetypes))
     
260. )
     
261. ;;16.2 [功能] 图层列表(常量*LAYS*)
     
262. ;;示例("0" "中心线" "文字" "DIM")
     
263. (defun MJ:ListLayers ()
     
264.   (MJ:ListCollectionMemberNames (vlax-Get-Property *DOC* 'Layers))
     
265. )
     
266. ;;16.3 [功能] 返回文字样式集合成员名称列表(常量*STS*)
     
267. (defun MJ:ListTextStyles ()
     
268.   (MJ:ListCollectionMemberNames (vlax-Get-Property *DOC* 'TextStyles))
     
269. )
     
270. ;;16.4 [功能] 返回尺寸样式集合成员名称列表
     
271. (defun MJ:ListDimStyles ()
     
272.   (MJ:ListCollectionMemberNames *DIMS*)
     
273. )
     
274. ;;16.5 [功能] 返回布局集合成员名称列表
     
275. (defun MJ:ListLayouts ()
     
276.   (MJ:ListCollectionMemberNames *LOUTS*)
     
277. )
     
278. ;;16.6 [功能] 返回词典集合成员名称列表
     
279. (defun MJ:ListDictionaries ()
     
280.   (MJ:ListCollectionMemberNames *DICS*)
     
281. )
     
282. ;;16.7 [功能] 返回块集合成员名称列表
     
283. (defun MJ:ListBlocks ()
     
284.   (MJ:ListCollectionMemberNames *BLKS*)
     
285. )
     
286. ;;16.8 [功能] 返回打印配置集合成员名称列表
     
287. (defun MJ:ListPlotConfigs ()
     
288.   (MJ:ListCollectionMemberNames (MJ:GetPlotConfigs))
     
289. )
     
290. ;;16.9 [功能] 返回视图集合成员名称列表
     
291. (defun MJ:ListViews ()
     
292.   (MJ:ListCollectionMemberNames (MJ:GetViews))
     
293. )
     
294. ;;16.10 [功能] 返回视口集合成员名称列表(同常量*VPS*)
     
295. (defun MJ:ListViewPorts ()
     
296.   (MJ:ListCollectionMemberNames (MJ:GetViewports))
     
297. )
     
298. ;;16.11 [功能] 返回组集合成员名称列表
     
299. (defun MJ:ListGroups ()
     
300.   (MJ:ListCollectionMemberNames (MJ:GetGroups))
     
301. )
     
302. ;;16.12 [功能] 返回注册程序集合成员名称列表
     
303. (defun MJ:ListRegApps ()
     
304.   (MJ:ListCollectionMemberNames (MJ:GetRegApps))
     
305. )
     
306. ;;17 [功能] 点表排序(141 143.1的更差)
     
307. ;;*****************************************************************************通用点表排序
     
308. ;;ssPts: 1 选择集，返回图元列表
     
309. ;;    2 点表(1到n维 1维时key只能是x或X)，返回点表
     
310. ;;   3 图元列表，返回图元列表
     
311. ;;Key: "xyzXYZ"任意组合,例如"yX",y在前表示y坐标优先，小y表示从小到大(注:二维点时，不能有z)
     
312. ;;FUZZ: 允许误差
     
313. ;;注:点表可以1到n维混合,Key长度不大于点的最小维数。
     
314. ;;示例1 (HH:ssPts:Sort (ssget) "YxZ" 0.5);返回(<Entity name: 7ef7b3a8> <Entity name: 7ef7b3a0>)
     
315. ;;示例2 (HH:ssPts:Sort (list '(2 3) '(3 5)) "Yx" 0.5);返回((3 5) (2 3))
     
316. ;;示例3 (HH:ssPts:Sort '(<Entity name: 7ef79a28> <Entity name: 7ef79a10>) "YxZ" 0.5)
     
317. ;;本程序是在fsxm的扩展 自贡黄明儒 2013年9月9日
     
318. (defun HH:ssPts:Sort (ssPts KEY FUZZ / E EN FUN LST N SORTPTS SORTSS)
     
319.   ;;1 点列表排序
     
320.   (defun sortpts (PTS FUN xyz FUZZ)
     
321.     (vl-sort pts
     
322.       '(lambda (a b)
     
323.   (if (not (equal (xyz a) (xyz b) fuzz))
     
324.     (fun (xyz a) (xyz b))
     
325.   )
     
326.        )
     
327.     )
     
328.   )
     
329.   ;;2 排序
     
330.   (defun sortpts1 (PTS KEY FUZZ)
     
331.     (setq Key (vl-string->list Key))
     
332.     (foreach xyz (reverse Key)
     
333.       (cond ((< xyz 100)
     
334.       (setq fun >)
     
335.       (setq xyz (nth (- xyz 88) (list car cadr caddr)))
     
336.      )
     
337.      (T
     
338.       (setq fun <)
     
339.       (setq xyz (nth (- xyz 120) (list car cadr caddr)))
     
340.      )
     
341.       )
     
342.       (setq Pts (sortpts Pts fun xyz fuzz))
     
343.     )
     
344.   )
     
345.   ;;3 本程序主程序
     
346.   (cond ((= (type ssPts) 'PICKSET)
     
347.   (repeat (setq n (sslength ssPts))
     
348.     (if (and (setq e (ssname ssPts (setq n (1- n))))
     
349.       (setq en (entget e))
     
350.         )
     
351.       (setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))
     
352.     )
     
353.   )
     
354.   (mapcar 'last (sortpts1 lst KEY FUZZ))
     
355. )
     
356. ((Listp ssPts)
     
357.   (cond ((vl-consp (car ssPts)) (sortpts1 ssPts KEY FUZZ))
     
358.         ((= (type (car ssPts)) 'ENAME)
     
359.   (foreach e ssPts
     
360.     (if (setq en (entget e))        
     
361.       (setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))
     
362.     )
     
363.   )
     
364.   (mapcar 'last (sortpts1 lst KEY FUZZ))
     
365.         )
     
366.   )
     
367. )
     
368.   )
     
369. )
     
370. ;;*****************************************************************************通用点表排序
     
371. ;;18 [功能] 集合->列表
     
372. ;; 示例: (MJ:CollectionList (MJ:GetLtypes)) 返回:线性列表
     
373. (defun MJ:CollectionList (Collection / name out)  
     
374.   (vlax-for each Collection
     
375.     (setq name (MJ:Name each))
     
376.     (setq out (cons name out))
     
377.   )
     
378.   (reverse out)
     
379. )
     
380. ;;19 [功能] 线型数量
     
381. (defun MJ:CountLtypes ()
     
382.   (MJ:CollectionCount (vlax-Get-Property *DOC* 'Linetypes))
     
383. )
     
384. ;;20 [功能] 对集合对象的每个成员执行指定函数的操作
     
385. ;; 示例: (MJ:MapCollection all-arcs 'MJ:DeleteObject)
     
386. (defun MJ:MapCollection (Collection qFunction)
     
387.   (vlax-map-collection Collection qFunction)
     
388. )
     
389. ;;20.1 [功能] 显示集合对象每个成员的方法和属性.既然是集合,方法是相同的
     
390. ;; 示例: (MJ:DumpCollection (MJ:GetLayers))
     
391. (defun MJ:DumpCollection (Collection)
     
392.   (MJ:MapCollection Collection 'vlax-dump-object)
     
393. )
     
394. ;;20.2 [功能] 删除对象
     
395. ;; 示例: (MJ:DeleteObject arc-object1)
     
396. (defun MJ:DeleteObject (obj)
     
397.   (princ "\n ***DeleteObject")
     
398.   (cond
     
399.     ((and
     
400.        (not (vlax-erased-p obj));存在
     
401.        (vlax-read-enabled-p obj);可读
     
402.        (vlax-write-enabled-p obj);可写
     
403.      )
     
404.      (vlax-invoke-method obj 'Delete)
     
405.      (if (not (vlax-object-released-p obj))
     
406.        (vlax-release-object obj);释放
     
407.      )
     
408.     )   
     
409.     (T (princ "\nCannot delete object!"))
     
410.   )   
     
411. )
     
412. ;;21.1 [功能] ename->vla对象
     
413. ;; 示例: (MJ:MakeObject (car (entsel)))
     
414. (defun MJ:MakeObject (entname)
     
415.   (cond
     
416.     ((= (type entname) 'ENAME)
     
417.      (*En2Obj* entname)
     
418.     )
     
419.     ((= (type entname) 'VLA-OBJECT)
     
420.      entname
     
421.     )
     
422.   )
     
423. )
     
424. ;;21.2 [功能] vla对象->ename
     
425. (defun MJ:MakeEname (object)
     
426.   (if (equal (type object) 'vla-object)
     
427.     (*Obj2En* object)
     
428.     object
     
429.   )
     
430. )
     
431. ;;22 [功能] 返回对象名称(见9)
     
432. ;; 示例: (= "AcDbArc" (MJ:ObjectType MJ:object))
     
433. (defun MJ:ObjectType (obj)
     
434.   (vlax-get-property obj 'ObjectName)
     
435. )
     
436. ;;23.1 编组开始(command "_.undo" "be")
     
437. (defun MJ:UndoBegin ()
     
438.   (vlax-invoke-method *DOC* 'StartUndoMark)
     
439. )
     
440. ;;23.2 编组结束(command "_.undo" "END")
     
441. (defun MJ:UndoEnd ()
     
442.   (vlax-invoke-method *DOC* 'EndUndoMark)
     
443. )
     
444. ;;24 [功能] 用一个对象的属性等修改另一个对象的属性
     
445. ;;示例(setq source (MJ:MakeObject(car (entsel))) target (MJ:MakeObject(car (entsel))))
     
446. ;; (MJ:CopyProp "Layer" source  target)用一个对象的图层等修改另一个对象的图层等
     
447. (defun MJ:CopyProp (propName source target)
     
448.   (cond
     
449.     ((member (strcase propName)
     
450.       '("LAYER"   "LINETYPE"    "COLOR"
     
451.         "LINETYPESCALE"  "LINEWEIGHT"    "PLOTSTYLENAME"
     
452.         "ELEVATION"  "THICKNESS"
     
453.        )
     
454.      )
     
455.      (cond
     
456.        ((and
     
457.    (not (vlax-erased-p source));存在
     
458.    (not (vlax-erased-p target));存在
     
459.    (vlax-read-enabled-p source);可读
     
460.    (vlax-write-enabled-p target);可写
     
461. )
     
462. (vlax-put-property
     
463.    target
     
464.    propName
     
465.    (vlax-get-property source propName);修改
     
466. )
     
467.        )   
     
468.        (T (princ "\n One or more objects inaccessible!"))
     
469.      )     
     
470.     )     
     
471.     (T (princ "\n Invalid property-key request!"))
     
472.   )   
     
473. )
     
474. ;;24.1 [功能] 用一个对象的'(图层 线型...)修改另一个对象的图层 线型...等
     
475. ;; 示例: (MJ:MapPropertyList '("Layer" "Color") arc-object1 arc-object2
     
476. (defun MJ:MapPropertyList (propList source target)
     
477.   (foreach prop propList
     
478.     (MJ:CopyProp prop source target)
     
479.   )
     
480. )
     
481. ;;25.1 [功能] 配置文件集合
     
482. (defun MJ:Profiles ()
     
483.   (vla-get-Profiles (MJ:AcadPrefs))
     
484. )
     
485. ;;25.2 [功能] 设置配置文件
     
486. ;; 示例:   (MJ:SetProfile "MJ:Profile")
     
487. (defun MJ:SetProfile (pname)
     
488.   (vl-load-com)
     
489.   (vla-put-ActiveProfile
     
490.     (vla-get-Profiles
     
491.       (vla-get-Preferences
     
492. *ACAD*
     
493.       )
     
494.     )
     
495.     pname
     
496.   )
     
497. )
     
498. ;;25.3 [功能] 重新装载配置文件
     
499. ;; 示例: (MJ:ProfileReLoad "profile1" "c:\\profiles\\profile1.arg")
     
500. (defun MJ:ProfileReLoad (name ARGname)
     
501.   (cond
     
502.     ((= (vlax-get-property (MJ:Profiles) 'ActiveProfile) name)
     
503.      ;; or following code.
     
504.      ;;(= (vla-get-ActiveProfile (MJ:Profiles)) name)
     
505.      (princ "\nCannot delete a profile that is in use.")
     
506.     )
     
507.     ((and
     
508.        (MJ:ProfileExists-p name)
     
509.        (findfile ARGname)
     
510.      )
     
511.      (MJ:ProfileDelete name)
     
512.      (MJ:ProfileImport name ARGname)
     
513.      (vla-put-ActiveProfile (MJ:Profiles) name)
     
514.     )
     
515.     ((and
     
516.        (not (MJ:ProfileExists-p name))
     
517.        (findfile ARGname)
     
518.      )
     
519.      (MJ:ProfileImport name ARGname)
     
520.      (vla-put-ActiveProfile (MJ:Profiles) name)
     
521.     )
     
522.     ((not (findfile ARGname))
     
523.      (princ (strcat "\nCannot locate ARG source: " ARGname))
     
524.     )
     
525.   )
     
526. )
     
527. ;;25.4 [功能] 重启默认配置文件
     
528. ;; 示例: (MJ:ProfileReset "profile1")
     
529. (defun MJ:ProfileReset (strName)
     
530.   (if (MJ:ProfileExists-p strName)
     
531.     (vlax-Invoke-Method
     
532.       (MJ:Profiles)
     
533.       'ResetProfile
     
534.       strName
     
535.     )
     
536.     (princ (strcat "\nProfile [" strName "] does not exist."))
     
537.   )
     
538. )
     
539. ;;25.5 [功能] 输出配置文件
     
540. ;; ARGS: arg-file(string), profile-name(string), T(Boolean)
     
541. ;; 示例: (MJ:ProfileExport "<<Unnamed Profile>>" "D:/test.arg" T)
     
542. (defun MJ:ProfileExport (strName strFilename BooleReplace)
     
543.   (if (MJ:ProfileExists-p strName)
     
544.     (if (not (findfile strFilename))
     
545.       (progn
     
546. (vlax-Invoke-Method
     
547.    (vlax-Get-Property (MJ:AcadPrefs) "Profiles")
     
548.    'ExportProfile
     
549.    strName
     
550.    strFilename
     
551. )
     
552. T
     
553.       )
     
554.       (if BooleReplace
     
555. (progn
     
556.    (vl-file-delete (findfile strFilename))
     
557.    (if (not (findfile strFilename))
     
558.      (progn
     
559.        (vlax-Invoke-Method
     
560.   (vlax-Get-Property (MJ:AcadPrefs) "Profiles")
     
561.   'ExportProfile
     
562.   strName
     
563.   strFilename
     
564.        )
     
565.        T      
     
566.      )   
     
567.      (princ "\nCannot replace ARG file, aborted.")
     
568.    )   
     
569. )   
     
570. (princ (strcat "\n" strFilename " already exists, aborted.")
     
571. )
     
572.       )   
     
573.     )   
     
574.   )   
     
575. )
     
576. ;;25.6 [功能] 输出配置文件
     
577. ;; NOTES: Export an existing profile to a new external .ARG file
     
578. ;; 示例: (MJ:ProfileExportX "<<Unnamed Profile>>" "D:/test1.arg")
     
579. (defun MJ:ProfileExportX (pName ARGfile)
     
580.   (cond
     
581.     ((MJ:ProfileExists-p pName)
     
582.      (vlax-invoke-method
     
583.        (MJ:Profiles)
     
584.        'ExportProfile
     
585.        pName
     
586.        ARGfile
     
587.        (vlax-make-variant 1 :vlax-vbBoolean)
     
588.        ;; == TRUE
     
589.      )
     
590.     )
     
591.     (T (princ "\nNo such profile exists to export."))
     
592.   )
     
593. )
     
594. ;;25.7 [功能] 输入配置文件
     
595. ;; ARGS: profile-name(string), arg-file(string)
     
596. ;; 示例: (MJ:ProfileImport "MJ:Profile" "c:/test.arg")
     
597. ;; VBA equivalent:             ;;
     
598. ;;  ThisDrawing.Application.preferences._          ;;
     
599. ;;     Profiles.ImportProfile _              ;;
     
600. ;;       strProfileToImport, strARGFileSource, True         ;;
     
601. (defun MJ:ProfileImport (pName ARGfile)
     
602.   (cond
     
603.     ((findfile ARGfile)
     
604.      (vlax-invoke-method
     
605.        (vlax-get-property (MJ:AcadPrefs) "Profiles")
     
606.        'ImportProfile
     
607.        pName
     
608.        ARGfile
     
609.        (vlax-make-variant 1 :vlax-vbBoolean)
     
610.        ;; == TRUE
     
611.      )
     
612.     )     ;
     
613.     (T (princ "\nARG file not found to import!"))
     
614.   )   
     
615. )
     
616. ;;25.8 [功能] 复制配置文件
     
617. ;; 示例: (MJ:ProfileCopy pName newName)
     
618. (defun MJ:ProfileCopy (Name1 Name2)
     
619.   (cond
     
620.     ((and
     
621.        (MJ:ProfileExists-p Name1)
     
622.        (not (MJ:ProfileExists-p Name2))
     
623.      )
     
624.      (vlax-invoke-method
     
625.        (MJ:Profiles)
     
626.        'CopyProfile
     
627.        Name1
     
628.        Name2
     
629.      )
     
630.     )     ;
     
631.     ((not (MJ:ProfileExists-p Name1))
     
632.      (princ "\nError: No such profile exists.")
     
633.     )     ;
     
634.     ((MJ:ProfileExists-p Name2)
     
635.      (princ "\nProfile already exists, copy failed.")
     
636.     )
     
637.   )
     
638. )
     
639. ;;25.9 [功能] 重命名配置文件
     
640. ;; 示例: (MJ:ProfileRename oldName newName)
     
641. (defun MJ:ProfileRename (oldName newName)
     
642.   (cond
     
643.     ((and
     
644.        (MJ:ProfileExists-p oldName)
     
645.        (not (MJ:ProfileExists-p newName))
     
646.      )
     
647.      (vlax-invoke-method
     
648.        (MJ:Profiles)
     
649.        'RenameProfile
     
650.        oldName
     
651.        newName
     
652.      )
     
653.     )  
     
654.     (T (princ))
     
655.     ;; add your error handling here?
     
656.   )
     
657. )
     
658. ;;25.10 [功能] 删除配置文件
     
659. ;; 示例: (MJ:ProfileDelete "MJ:Profile")
     
660. (defun MJ:ProfileDelete (pName)
     
661.   (vlax-invoke-method
     
662.     (vlax-get-property (MJ:AcadPrefs) "Profiles")
     
663.     'DeleteProfile
     
664.     pName
     
665.   )
     
666. )
     
667. ;;25.11 [功能] 配置文件是否存在
     
668. ;; 示例: (if (MJ:ProfileExists-p "<<Unnamed Profile>>") ...)
     
669. (defun MJ:ProfileExists-p (pName)
     
670.   (member (strcase pName) (mapcar 'strcase (MJ:ProfileList)))
     
671. )
     
672. ;;25.12 [功能] 配置文件列表
     
673. ;;返回示例("<<Unnamed Profile>>" "yky_m2006")
     
674. (defun MJ:ProfileList (/ hold)
     
675.   (vlax-invoke-method
     
676.     (vlax-get-property (MJ:AcadPrefs) "Profiles")
     
677.     'GetAllProfileNames
     
678.     'hold
     
679.   )
     
680.   (if hold
     
681.     (vlax-safearray->list hold)
     
682.   )
     
683. )
     
684. ;;26.1 [功能] 非当前文档,关闭(不保存)
     
685. ;; Author:    Frank Whaley
     
686. (defun MJ:CloseAll (/ item cur)
     
687.   (vl-load-com)
     
688.   (vlax-for item *DOCS*
     
689.     (if (= (vla-get-active item) :vlax-false)
     
690.       (vla-close item :vlax-false)
     
691.       (setq cur item)
     
692.     )
     
693.   )  
     
694.   ;;(vla-sendcommand cur "_.CLOSE")
     
695.   (command "vbastmt" "AcadApplication.activeDocument.close false ");关闭当前文档
     
696. )
     
697. ;;27.1 [功能] 保存所有文档
     
698. (defun MJ:SaveAllDocs (/ item)
     
699.   (vlax-for item *DOCS*
     
700.     (vla-save item)
     
701.   )
     
702. )
     
703. ;;27.2 [功能] 活动文档是否已经保存?
     
704. (defun MJ:Saved-p ()
     
705.   (= (vla-get-saved *DOC*) :vlax-True)
     
706. )
     
707. ;;acR12_DXF,AutoCAD Release12/LT2 DXF (*.dxf)
     
708. ;;ac2000_dwg,AutoCAD 2000 DWG (*.dwg)
     
709. ;;ac2000_dxf,AutoCAD 2000 DXF (*.dxf)
     
710. ;;ac2000_Template,AutoCAD 2000 Drawing Template File (*.dwt)
     
711. ;;ac2004_dwg,AutoCAD 2004 DWG (*.dwg)
     
712. ;;ac2004_dxf,AutoCAD 2004 DXF (*.dxf)
     
713. ;;ac2004_Template,AutoCAD 2004 Drawing Template File (*.dwt)
     
714. ;;acNative,A synonym for the current drawing release format
     
715. ;;AcUnknown,Read-only. The drawing type is unknown or invalid.
     
716. ;;27.3 [功能] 另存为2K格式
     
717. (defun MJ:SaveAs2000 (name)
     
718.   (vla-saveas *DOC* name acR15_DWG)
     
719. )
     
720. ;;27.4 [功能] 另存为R14格式
     
721. (defun MJ:SaveAsR14 (name)
     
722.   (vla-saveas *DOC* name acR14_DWG)
     
723. )
     
724. ;;28.1 [功能] 清理打开文档
     
725. (defun MJ:PurgeAllDocs (/ item cur)
     
726.   (vlax-for item *DOCS*
     
727.     (vla-PurgeAll item)
     
728.   )
     
729. )
     
730. ;;28.2 [功能] 删除未使用的图层,比purge彻底
     
731. (defun MJ:LayerDelete ()
     
732.   (vl-Load-Com)
     
733.   (vl-Catch-All-Apply
     
734.     '(lambda ()
     
735.        (vla-Remove
     
736.   (vla-GetExtensionDictionary
     
737.     (vla-Get-Layers
     
738.       *DOC*
     
739.     )
     
740.   )
     
741.   "ACAD_LAYERFILTERS"
     
742.        )
     
743.      )
     
744.   )  
     
745.   (princ)
     
746. )
     
747. ;;29.1 [功能] 取得选定块的指定属性
     
748. ;; (MJ:GetTagTextStringByRef (*En2Obj* (car (entsel))) "设计")
     
749. (defun MJ:GetTagTextStringByRef (br tagname / atts tag str)
     
750.   (if (and
     
751. (= (vla-get-hasattributes br) :vlax-true)
     
752. (safearray-value
     
753.    (setq atts
     
754.    (vlax-variant-value
     
755.      (vla-getattributes br)
     
756.    )
     
757.    )
     
758. )
     
759.       )
     
760.     (foreach tag (vlax-safearray->list atts)
     
761.       (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
     
762. (setq str (vla-get-TextString tag))
     
763.       )
     
764.     )
     
765.   )
     
766.   str
     
767. )
     
768. ;;29.2 [功能] 取得块属性列表
     
769. ;(MJ:GetAttributes (car (entsel)))取得属性列表(("比例" . "") ("材料" . "Q235"))
     
770. (defun MJ:GetAttributes (ent / blkref lst)
     
771.   (if (= (vla-Get-ObjectName
     
772.     (setq blkref (vlax-Ename->vla-Object ent))
     
773.   )
     
774.   "AcDbBlockReference"
     
775.       )
     
776.     (if (vla-Get-HasAttributes blkref)
     
777.       (mapcar
     
778. '(lambda (x)
     
779.     (setq
     
780.       lst (cons
     
781.      (cons (vla-Get-TagString x) (vla-Get-TextString x))
     
782.      lst
     
783.    )
     
784.     )
     
785.   )
     
786. (vlax-safearray->list
     
787.    (vlax-variant-value (vla-GetAttributes blkref))
     
788. )
     
789.       )     
     
790.     )     
     
791.   )     
     
792.   (reverse lst)
     
793. )
     
794. ;;29.3 [功能] [功能] 取得块属性列表
     
795. ;; 示例:   (MJ:GetAttributes (car (entsel))返回(("比例" "" <Entity name: 7efd2ad0>)(...))
     
796. (defun MJ:GetAttributes (ent / lst)  
     
797.   (if (safearray-value
     
798. (setq lst
     
799.         (vlax-variant-value
     
800.    (vla-getattributes
     
801.      (vlax-ename->vla-object ent)
     
802.    )
     
803.         )
     
804. )
     
805.       )
     
806.     (mapcar
     
807.       '(lambda (x)
     
808.   (list
     
809.     (vla-get-tagstring x)
     
810.     (vla-get-textstring x)
     
811.     (*Obj2En* x)
     
812.   )
     
813.        )
     
814.       (vlax-safearray->list lst)
     
815.     )
     
816.   )
     
817. )
     
818. ;;29.4 [功能] Returns a list of constant attributes tags and their values
     
819. ;; 示例:   (MJ:GetConstantAttributes (car (entsel)))
     
820. (defun MJ:GetConstantAttributes (ent / atts)
     
821.   (vl-load-com)
     
822.   (cond
     
823.     ((and (safearray-value
     
824.      (setq atts
     
825.      (vlax-variant-value
     
826.        (vla-getconstantattributes
     
827.          (vlax-ename->vla-object ent)
     
828.        )
     
829.      )
     
830.      )
     
831.    )
     
832.      )
     
833.      (mapcar
     
834.        '(lambda (x)
     
835.    (cons (vla-get-tagstring x) (vla-get-textstring x))
     
836. )
     
837.        (vlax-safearray->list atts)
     
838.      )
     
839.     )     ;
     
840.     (T
     
841.      (princ
     
842.        (strcat
     
843.   "\nThe block reference ""
     
844.   (vla-get-Name (vlax-ename->vla-object ent))
     
845.   "" doesn't include constant attributes tags and their values"
     
846.        )
     
847.      )
     
848.     )
     
849.   )
     
850. )
     
851. ;;30.1 [功能] 更改块指定属性
     
852. ;; (MJ:PutTagTextString "块名" tagname "new value")
     
853. (defun MJ:PutTagTextString
     
854.       (bn tagname textstring / layout i atts tag)
     
855.   (vlax-for layout *LOUTS*
     
856.     (vlax-for i (vla-get-block layout)
     
857.       (if (and
     
858.      (= (vla-get-objectname i) "AcDbBlockReference")
     
859.      (= (strcase (vla-get-name i)) (strcase bn))
     
860.    )
     
861. (if (and
     
862.        (= (vla-get-hasattributes i) :vlax-true)
     
863.        (safearray-value
     
864.   (setq atts
     
865.          (vlax-variant-value
     
866.     (vla-getattributes i)
     
867.          )
     
868.   )
     
869.        )
     
870.      )
     
871.    (foreach tag (vlax-safearray->list atts)
     
872.      (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
     
873.        (vla-put-TextString tag textstring)
     
874.      )
     
875.    )
     
876.    (vla-update i)
     
877. )
     
878.       )
     
879.     )
     
880.   )
     
881. )
     
882. ;;30.2 [功能] 块的属性值改为新值---纯lisp法 by 自贡黄明儒
     
883. ;;示例(attchg (car (entsel)) "设计" "aaa")
     
884. (defun attchg (ent attname new / EN ENTLIST)
     
885.   (defun MJ:DXF (IT LST)
     
886.     (cdr (assoc IT LST))
     
887.   )
     
888.   (if (and (setq en ent)
     
889.     (setq entlist (entget en))
     
890.     (equal (MJ:DXF 0 entlist) "INSERT")
     
891.     (equal (MJ:DXF 66 entlist) 1) ;=1则块有属性值
     
892.       )
     
893.     (while (and en
     
894.   (setq en (entnext en))
     
895.   (setq entlist (entget en))
     
896.   (equal (MJ:DXF 0 entlist) "ATTRIB")
     
897.     )
     
898.       (if (= (strcase (MJ:DXF 2 entlist)) (strcase attname))
     
899. (progn (entmod (subst (cons 1 new) (assoc 1 entlist) entlist))
     
900.         (entupd ent)
     
901.         (setq en nil)
     
902. )
     
903.       )
     
904.     )
     
905.   )
     
906.   (princ)
     
907. )
     
908. ;;30.3 [功能] 更改选定块的指定属性
     
909. ;; (MJ:PutTagTextStringByRef (*En2Obj* (car (entsel))) "设计" "new value")
     
910. (defun MJ:PutTagTextStringByRef (br tagname textstring / atts tag)
     
911.   (if (and
     
912. (= (vla-get-hasattributes br) :vlax-true)
     
913. (safearray-value
     
914.    (setq atts
     
915.    (vlax-variant-value
     
916.      (vla-getattributes br)
     
917.    )
     
918.    )
     
919. )
     
920.       )
     
921.     (foreach tag (vlax-safearray->list atts)
     
922.       (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
     
923. (vla-put-TextString tag textstring)
     
924.       )
     
925.     )
     
926.     (vla-update br)
     
927.   )
     
928. )
     
929. ;;30.4 [功能] 更改块多个属性
     
930. ;;(setq blk (car (entsel)))
     
931. ;;(MJ:ChangeAttributes (list blk (cons "设计" "AA")(cons "名称" "BB")))
     
932. (defun MJ:ChangeAttributes (lst / blk itm atts)
     
933.   (setq blk (vlax-Ename->vla-Object (car lst))
     
934. lst (cdr lst)
     
935.   )
     
936.   (if (= (vla-Get-HasAttributes blk) :vlax-true) ;如果有属性
     
937.     (progn
     
938.       (setq atts (vlax-SafeArray->list
     
939.      (vlax-Variant-Value (vla-GetAttributes blk))
     
940.    )
     
941.       )     
     
942.       (foreach item lst
     
943. (mapcar
     
944.    '(lambda (x)
     
945.       (if
     
946.         (= (strcase (car item)) (strcase (vla-Get-TagString x)))
     
947.   (vla-Put-TextString x (cdr item))
     
948.       )   
     
949.     )
     
950.    atts
     
951. )   
     
952.       )     
     
953.       (vla-Update blk)
     
954.     )
     
955.   )   
     
956. )
     
957. ;;30.5 [功能] 更改块多个属性
     
958. ;; 示例: (MJ:ChangeAttribute (list ename '("MJ:Attribute" . "NewValue")))
     
959. ;; 示例 (MJ:ChangeAttribute (list (car (entsel)) '("设计" . "NewValue")))
     
960. (defun MJ:ChangeAttribute (lst / item atts)
     
961.   (vl-load-com)
     
962.   (if (safearray-value
     
963. (setq atts
     
964.         (vlax-variant-value
     
965.    (vla-getattributes (vlax-ename->vla-object (car lst)))
     
966.         )
     
967. )
     
968.       )
     
969.     (progn
     
970.       (foreach item (cdr lst)
     
971. (mapcar
     
972.    '(lambda (x)
     
973.       (if
     
974.         (= (strcase (car item)) (strcase (vla-get-tagstring x)))
     
975.   (vla-put-textstring x (cdr item))
     
976.       )
     
977.     )
     
978.    (vlax-safearray->list atts)
     
979. )
     
980.       )
     
981.       (vla-update (vlax-ename->vla-object (car lst)))
     
982.     )
     
983.   )
     
984. )
     
985. ;;31.1 [功能] 返回指定(块名 标记 属性值)的块 选择集
     
986. ;; 示例:   (MJ:SelectAttributedBlocks '("块名" "Tag" "value"))
     
987. (defun MJ:SelectAttributedBlocks (lst / ss ss2 c ent att)  
     
988.   (if (setq ss (ssget "X" (list (cons 0 "INSERT") (cons 2 (car lst)))))
     
989.     (progn
     
990.       (setq c 0)
     
991.       (repeat (sslength ss)
     
992. (setq ent (vlax-ename->vla-object (ssname ss c)))
     
993. (if (vla-get-hasattributes ent)
     
994.    (foreach att (vlax-safearray->list
     
995.     (vlax-variant-value (vla-getattributes ent))
     
996.          )
     
997.      (if
     
998.        (= (strcase (vla-get-tagstring att)) (strcase (cadr lst)))
     
999.         (if (= (strcase (vla-get-textstring att))
     
1000.         (strcase (caddr lst))
      
1001.      )
      
1002.    (progn
      
1003.      (vla-highlight ent :vlax-true)
      
1004.      (if (not ss2)
      
1005.        (setq ss2 (ssadd (ssname ss c)))
      
1006.        (ssadd (ssname ss c) ss2)
      
1007.      )
      
1008.    )
      
1009.         )
      
1010.      )
      
1011.    )
      
1012. )
      
1013. (setq c (1+ c))
      
1014.       )
      
1015.     )
      
1016.   )
      
1017.   ss2
      
1018. )
      
1019. ;;31.2 [功能] 返回指定(块名 标记 属性值)的块 选择集
      
1020. ;; (MJ:FindBlockTagValue "blockname" "tagname" "tagvalue")
      
1021. (defun MJ:FindBlockTagValue
      
1022.        (bn tagname value / layout i atts tag sset c)
      
1023.   (vlax-for layout *LOUTS*
      
1024.     (vlax-for i (vla-get-block layout)
      
1025.       (if (and
      
1026.      (= (vla-get-objectname i) "AcDbBlockReference")
      
1027.      (= (strcase (vla-get-name i)) (strcase bn))
      
1028.    )
      
1029. (if (and
      
1030.        (= (vla-get-hasattributes i) :vlax-true)
      
1031.        (safearray-value
      
1032.   (setq atts
      
1033.          (vlax-variant-value
      
1034.     (vla-getattributes i)
      
1035.          )
      
1036.   )
      
1037.        )
      
1038.      )
      
1039.    (progn
      
1040.      (foreach tag (vlax-safearray->list atts)
      
1041.        (if (and
      
1042.       (= (strcase tagname)
      
1043.          (strcase (vla-get-TagString tag))
      
1044.       )
      
1045.       (= value (vla-get-TextString tag))
      
1046.     )
      
1047.   (progn
      
1048.     (if (not sset)
      
1049.       (setq sset (ssadd (*Obj2En* i)))
      
1050.       (ssadd (*Obj2En* i) sset)
      
1051.     )
      
1052.   )
      
1053.        )
      
1054.      )
      
1055.    )
      
1056. )
      
1057.       )
      
1058.     )
      
1059.   )
      
1060.   (sssetfirst nil sset)
      
1061. )
      
1062. ;;32.1 [功能] 更改属性位置
      
1063. ;; (MJ:ChangeTagIns "sheet-text" "a3-scale" '(703.4722 17.8350 0))
      
1064. (defun MJ:ChangeTagIns (bn tagname ins / layout i atts tag)
      
1065.   (defun list->variantArray (ptsList / arraySpace sArray)
      
1066.     (setq arraySpace
      
1067.     (vlax-make-safearray
      
1068.       vlax-vbdouble
      
1069.       (cons 0 (- (length ptsList) 1))
      
1070.     )
      
1071.     )
      
1072.     (setq sArray (vlax-safearray-fill arraySpace ptsList))
      
1073.     (vlax-make-variant sArray)
      
1074.   )
      
1075.   (vlax-for layout *LOUTS*
      
1076.     (vlax-for i (vla-get-block layout)
      
1077.       (if (and
      
1078.      (= (vla-get-objectname i) "AcDbBlockReference")
      
1079.      (= (strcase (vla-get-name i)) (strcase bn))
      
1080.    )
      
1081. (if (and
      
1082.        (= (vla-get-hasattributes i) :vlax-true)
      
1083.        (safearray-value
      
1084.   (setq atts
      
1085.          (vlax-variant-value
      
1086.     (vla-getattributes i)
      
1087.          )
      
1088.   )
      
1089.        )
      
1090.      )
      
1091.    (foreach tag (vlax-safearray->list atts)
      
1092.      (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
      
1093.        (vla-put-InsertionPoint tag (list->variantArray ins))
      
1094.      )
      
1095.    )
      
1096.    (vla-update i)
      
1097. )
      
1098.       )
      
1099.     )
      
1100.   )
      
1101. )
      
1102. ;;32.2 [功能] 更改块属性宽度
      
1103. ;; (MJ:ChangeTagWidth <block name> <tag name> <tag height>)
      
1104. ;; (MJ:ChangeTagWidth "panel1" "drw-no" 0.97)
      
1105. (defun MJ:ChangeTagWidth (bn tagname tagwidth / layout i atts tag)
      
1106.   (vlax-for layout *LOUTS*
      
1107.     (vlax-for i (vla-get-block layout)
      
1108.       (if (and
      
1109.      (= (vla-get-objectname i) "AcDbBlockReference")
      
1110.      (= (strcase (vla-get-name i)) (strcase bn))
      
1111.    )
      
1112. (if (and
      
1113.        (= (vla-get-hasattributes i) :vlax-true)
      
1114.        (safearray-value
      
1115.   (setq atts
      
1116.          (vlax-variant-value
      
1117.     (vla-getattributes i)
      
1118.          )
      
1119.   )
      
1120.        )
      
1121.      )
      
1122.    (foreach tag (vlax-safearray->list atts)
      
1123.      (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
      
1124.        (vla-put-scalefactor tag tagwidth)
      
1125.      )
      
1126.    )
      
1127.    (vla-update i)
      
1128. )
      
1129.       )
      
1130.     )
      
1131.   )
      
1132. )
      
1133. ;;32.3 [功能] 更改块属性高度
      
1134. ;; (MJ:ChangeTagHeight <block name> <tag name> <tag height>)
      
1135. ;; (MJ:ChangeTagHeight "sheet-text" "client-drw" 0.97)
      
1136. (defun MJ:ChangeTagHeight
      
1137.      (bn tagname tagheight / layout i atts tag)
      
1138.   (vlax-for layout *LOUTS*
      
1139.     (vlax-for i (vla-get-block layout)
      
1140.       (if (and
      
1141.      (= (vla-get-objectname i) "AcDbBlockReference")
      
1142.      (= (strcase (vla-get-name i)) (strcase bn))
      
1143.    )
      
1144. (if (and
      
1145.        (= (vla-get-hasattributes i) :vlax-true)
      
1146.        (safearray-value
      
1147.   (setq atts
      
1148.          (vlax-variant-value
      
1149.     (vla-getattributes i)
      
1150.          )
      
1151.   )
      
1152.        )
      
1153.      )
      
1154.    (foreach tag (vlax-safearray->list atts)
      
1155.      (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
      
1156.        (vla-put-height tag tagheight)
      
1157.      )
      
1158.    )
      
1159.    (vla-update i)
      
1160. )
      
1161.       )
      
1162.     )
      
1163.   )
      
1164. )
      
1165. ;;33 [功能] 列表块插入点(Y排序)
      
1166. ;; (MJ:ListBlockIns "BTL")
      
1167. ;; return value example:
      
1168. ;; ((341.385 29.2937 0.0 #<VLA-OBJECT IAcadBlockReference 071b9e24>)
      
1169. ;;  (341.385 34.2937 0.0 #<VLA-OBJECT IAcadBlockReference 071b9e74>)
      
1170. ;;  (341.385 39.2937 0.0 #<VLA-OBJECT IAcadBlockReference 071bd184>))
      
1171. (defun MJ:ListBlockIns (bn / layout i pl)
      
1172.   (vlax-for layout *LOUTS*
      
1173.     (vlax-for i (vla-get-block layout)
      
1174.       (if (and
      
1175.      (= (vla-get-objectname i) "AcDbBlockReference")
      
1176.      (= (strcase (vla-get-name i)) (strcase bn))
      
1177.    )
      
1178. (setq pl
      
1179.         (cons
      
1180.    (append (safearray-value
      
1181.       (vlax-variant-value (vla-get-InsertionPoint i))
      
1182.     )
      
1183.     (list i)
      
1184.    )
      
1185.    pl
      
1186.         )
      
1187. )
      
1188.       )
      
1189.     )
      
1190.   )
      
1191.      ; sort by y-value
      
1192.   (vl-sort pl
      
1193.     (function (lambda (e1 e2)
      
1194.          (< (cadr e1) (cadr e2))
      
1195.        )
      
1196.     )
      
1197.   )
      
1198. )
      
1199. ;;34 [功能] 块集的某一属性,显示块的x(or y z)值
      
1200. ;; Arguments: ss块集  attname属性 ordinate(0=X, 1=Y, 2=Z)
      
1201. ;; 示例:   (MJ:LabelOrdinate ss "设计" 0)
      
1202. (defun MJ:LabelOrdinate (ss attname ordinate / c block atts val att)
      
1203.   (vl-load-com)
      
1204.   (setq c -1)
      
1205.   (repeat (sslength ss)
      
1206.     (setq block (vlax-ename->vla-object
      
1207.     (ssname ss (setq c (1+ c)))
      
1208.   )
      
1209.    atts (vlax-safearray->list
      
1210.     (vlax-variant-value
      
1211.       (vla-getattributes block)
      
1212.     )
      
1213.   )
      
1214.    val (rtos
      
1215.     (nth ordinate
      
1216.          (vlax-safearray->list
      
1217.     (vlax-variant-value
      
1218.       (vla-get-insertionpoint block)
      
1219.     )
      
1220.          )
      
1221.     )
      
1222.     2
      
1223.     0
      
1224.   )
      
1225.     )
      
1226.     (foreach att atts
      
1227.       (if (= (strcase attname) (strcase (vla-get-tagstring att)))
      
1228. (vla-put-textstring att val)
      
1229.       )
      
1230.     )
      
1231.     (vla-update block)
      
1232.   )
      
1233.   (princ)
      
1234. )
      
1235. ;;35.1 [功能] 块中删除对象
      
1236. ;; 示例:   (MJ:DeleteObjectFromBlock (car (nentsel)))
      
1237. ;; Notes:     1. As shown, you can use the NENTSEL function to obtain the name of an entity within a block.
      
1238. ;;            2. Existing block reference will not show a change until you regen the drawing.
      
1239. (defun MJ:DeleteObjectFromBlock (ent / doc blk)  
      
1240.   (setq ent (vlax-ename->vla-object ent)
      
1241. blk (vla-ObjectIdToObject *DOC* (vla-get-OwnerID ent))
      
1242.   )
      
1243.   (vla-Delete ent)
      
1244.   (vla-get-Count blk)
      
1245. )
      
1246. ;;35.2 [功能] 块增加对象
      
1247. ;; 示例:   (MJ:AddObjectsToBlock (car (entsel)) (ssget))
      
1248. ;; Notes:     Existing block references will not show a change until you
      
1249. ;;            regen the drawing
      
1250. (defun MJ:AddObjectsToBlock (blk ss / doc blkref blkdef inspt refpt)
      
1251.   (vl-load-com)
      
1252.   (setq blkref (vlax-ename->vla-object blk)
      
1253. blkdef (vla-Item (vla-get-Blocks *DOC*) (vla-get-Name blkref))
      
1254. inspt (vlax-variant-value (vla-get-InsertionPoint blkref))
      
1255. ssarray (SS->Array ss)
      
1256. refpt (vlax-3d-point '(0 0 0))
      
1257.   )
      
1258.   (foreach ent (vlax-safearray->list ssarray)
      
1259.     (vla-Move ent inspt refpt)
      
1260.   )
      
1261.   (vla-CopyObjects *DOC* ssarray blkdef)
      
1262.   (foreach ent (vlax-safearray->list ssarray)
      
1263.     (vla-Delete ent)
      
1264.   )
      
1265.   (princ)
      
1266. )
      
1267. ;;35.3  [功能] 返回指定块每一个引用实体名列表
      
1268. ;; 注:未能验证是否正确?(MJ:ListBLockRefs "BTL")
      
1269. (defun MJ:ListBLockRefs (blkName / lst)
      
1270.   (setq lst (entget
      
1271.        (cdr
      
1272.   (assoc 330 (entget (tblobjname "block" blkName)))
      
1273.        )
      
1274.      )
      
1275.   )
      
1276.   (apply
      
1277.     'append
      
1278.     (mapcar '(lambda (x)
      
1279.         (if (entget (cdr x))
      
1280.    (list (cdr x))
      
1281.         )
      
1282.       )
      
1283.      (repeat 2
      
1284.        (setq lst (reverse (cdr (member (assoc 102 lst) lst))))
      
1285.      )
      
1286.     )
      
1287.   )
      
1288. )
      
1289. ;;35.4 [功能] 块引用名列表Returns a list conaining the entity names of any block definitions that
      
1290. ;;            reference the specified block
      
1291. ;; 示例:   (MJ:GetParentBlocks "BTL")
      
1292. (defun MJ:GetParentBlocks (blkName / doc)  
      
1293.   (apply
      
1294.     'append
      
1295.     (mapcar
      
1296.       '(lambda (x)
      
1297.   (if (= :vlax-false
      
1298.   (vla-get-IsLayout
      
1299.     (vla-ObjectIdToObject
      
1300.       *DOC*
      
1301.       (vla-get-OwnerId (vlax-ename->vla-object x))
      
1302.     )
      
1303.   )
      
1304.       )
      
1305.     (list x)
      
1306.   )
      
1307.        )
      
1308.       (MJ:ListBLockRefs blkName)
      
1309.     )
      
1310.   )
      
1311. )
      
1312. ;;36 [功能] 删除指定名的所有块
      
1313. ;; (MJ:EraseBlock "BTL");删除名叫"BTL"的所有块
      
1314. (defun MJ:EraseBlock (bn / layout i)
      
1315.   (vlax-for layout *LOUTS*
      
1316.     (vlax-for i (vla-get-block layout)
      
1317.       (if (and
      
1318.      (= (vla-get-objectname i) "AcDbBlockReference")
      
1319.      (= (strcase (vla-get-name i)) (strcase bn))
      
1320.    )
      
1321. (vla-Delete i)
      
1322.       )
      
1323.     )
      
1324.   )
      
1325. )
      
1326. ;;37 [功能] 块名"BTL"是否存在
      
1327. ;; (MJ:ExistBlock "BTL"是)
      
1328. (defun MJ:ExistBlock (bn / layout i exist)
      
1329.   (vlax-for layout *LOUTS*
      
1330.     (vlax-for i *BLKS*
      
1331.       (if (and
      
1332.      (= (vla-get-objectname i) "AcDbBlockReference")
      
1333.      (= (strcase (vla-get-name i)) (strcase bn))
      
1334.    )
      
1335. (setq exist T)
      
1336.       )
      
1337.     )
      
1338.   )
      
1339.   exist
      
1340. )
      
1341. ;;38.1 [功能] 块更名(块bn nn必须存在)
      
1342. ;; (MJ:RenameBlock "b1" "b2")块"b1"更名为"b2"
      
1343. (defun MJ:RenameBlock (bn nn / layout i)
      
1344.   (vlax-for layout *LOUTS*
      
1345.     (vlax-for i (vla-get-block layout)
      
1346.       (if (and
      
1347.      (= (vla-get-objectname i) "AcDbBlockReference")
      
1348.      (= (strcase (vla-get-name i)) (strcase bn))
      
1349.    )
      
1350. (vla-put-name i nn)
      
1351.       )
      
1352.     )
      
1353.   )
      
1354. )
      
1355. ;;38.2 [功能] 块更名
      
1356. ;;名为bn的块存在,名为nn的块不存在
      
1357. ;;(MJ:RenameBlock1 "ccd1" "ccd2")
      
1358. (defun MJ:RenameBlock1 (bn nn / BLOCK)  
      
1359.   (vla-put-name (vla-item (vla-get-blocks *DOC*) bn) nn)  
      
1360. )
      
1361. ;;39 [功能] 块名例表
      
1362. ;; 返回示例("*D5" "A$$C263E5435" "b2" "b1")
      
1363. (defun MJ:blocks (/ b bn tl)
      
1364.   (vlax-for b (vla-get-blocks *DOC*)
      
1365.     (if (= (vla-get-islayout b) :vlax-false)
      
1366.       (setq tl (cons (vla-get-name b) tl))
      
1367.     )
      
1368.   )
      
1369.   (reverse tl)
      
1370. )
      
1371. ;;40 [功能] XRef图块列表 a list of all xref names
      
1372. ;;返回示例  ("xref1" "x2")
      
1373. (defun MJ:xrefs (/ b bn tl)
      
1374.   (vlax-for b (vla-get-blocks *DOC*)
      
1375.     (if (= (vla-get-isxref b) :vlax-true)
      
1376.       (setq tl (cons (vla-get-name b) tl))
      
1377.     )
      
1378.   )
      
1379.   (reverse tl)
      
1380. )
      
1381. ;;41 [功能] 返回名为"bn"的XRef图块实体列表
      
1382. ;; 返回示例 (<Entity name: 2ea6290> <Entity name: 2ea6288>)
      
1383. (defun blockrefs (bn / lst ed)
      
1384.   (if (setq ed (tblobjname "block" bn))
      
1385.     (setq
      
1386.       lst (entget
      
1387.      (cdr (assoc 330 (entget ed)))
      
1388.    )
      
1389.     )
      
1390.   )
      
1391.   (apply
      
1392.     'append
      
1393.     (mapcar '(lambda (x)
      
1394.         (list (cdr x))
      
1395.       )
      
1396.      (cdr (reverse (cdr (member (assoc 102 lst) lst))))
      
1397.     )
      
1398.   )
      
1399. )
      
1400. ;;42 [功能] 返回包容点集的最小点最大点列表
      
1401. ;; (MJ:Extents '((1 0 0) (2 2 0) (1 2 0)))
      
1402. (defun MJ:Extents (plist /)
      
1403.   (list
      
1404.     (apply 'mapcar (cons 'min plist))
      
1405.     (apply 'mapcar (cons 'max plist))
      
1406.   )
      
1407. )
      
1408. ;;43.1 [功能] 两点中点
      
1409. (defun MJ:Mid (pts / P1 P2 X Y)
      
1410.   (setq p1 (car pts) p2 (cadr pts))
      
1411.   (if (= (length p1) (length p2))
      
1412.     nil
      
1413.     (setq p1 (list (car p1) (cadr p1))
      
1414.    p2 (list (car p2) (cadr p2))
      
1415.     )
      
1416.   )
      
1417.   (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2)
      
1418. )
      
1419. ;;43.2 [功能] <起点>,<中点>,<终点>列表  ;By 无痕
      
1420. (DEFUN xl-3p (e / ps pe pm)
      
1421.   (setq ps (vlax-curve-getstartparam e)
      
1422. pe (vlax-curve-getendparam e)
      
1423. pm (/ (- pe ps) 2)
      
1424.   )
      
1425.   (mapcar 'vlax-curve-getpointatparam
      
1426.    (list e e e)
      
1427.    (list ps pm pe)
      
1428.   )
      
1429. )
      
1430. ;;44 [功能] 求矩形中心
      
1431. ;;示例 (MJ:RectCenter (car (entsel)))
      
1432. (defun MJ:RectCenter (rec)
      
1433.   (MJ:Mid (MJ:Extents (MJ:Massoc 10 (entget rec))))
      
1434. )
      
1435. ;;45 [功能] 返回封闭曲线质心二维坐标
      
1436. ;; 示例:   (MJ:Centroid (car (entsel)))
      
1437. (defun MJ:Centroid (poly / pl ms va reg cen)
      
1438.   (vl-load-com)
      
1439.   (setq pl (vlax-ename->vla-object poly)
      
1440. ms (vla-get-modelspace
      
1441.       *DOC*
      
1442.     )
      
1443. va (vlax-make-safearray vlax-vbObject '(0 . 0))
      
1444.   )
      
1445.   (vlax-safearray-put-element va 0 pl)
      
1446.   (setq reg (car (vlax-safearray->list
      
1447.      (vlax-variant-value (vla-addregion ms va))
      
1448.    )
      
1449.      )
      
1450. cen (vla-get-centroid reg)
      
1451.   )
      
1452.   (vla-delete reg)
      
1453.   (vlax-safearray->list (vlax-variant-value cen))
      
1454. )
      
1455. ;;46.1 [功能] 多段线各顶点(见99.3)
      
1456. ;;示例 (MJ:Massoc 10 (entget (car (entsel))))
      
1457. ;; Notes:特别适合多段线各顶点
      
1458. (defun MJ:Massoc (key alist)
      
1459.   (apply
      
1460.     'append
      
1461.     (mapcar '(lambda (x)
      
1462.         (if (eq (car x) key)
      
1463.    (list (cdr x))
      
1464.         )
      
1465.       )
      
1466.      alist
      
1467.     )
      
1468.   )
      
1469. )
      
1470. ;;46.2 [功能] pline,lwpline点坐标表  By 无痕
      
1471. ;;示例(vxs (car (entsel))),返回三维点坐标
      
1472. (defun vxs (e / i v lst)
      
1473.   (setq i -1)
      
1474.   (while
      
1475.     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
      
1476.      (setq lst (cons v lst))
      
1477.   )
      
1478.   (reverse lst)
      
1479. )
      
1480. ;;46.3 [功能] 返回包含每一出现在列表中的指定键的cdr(点对的后部分)的列表。
      
1481. ;;;示例 (MJ:massoc 10 (entget (car (entsel))))
      
1482. ;;注意 该函数特别适合用于找到细多义线上的所有顶点。
      
1483. (defun MJ:massoc (key alist)
      
1484.   (mapcar 'cdr
      
1485.    (vl-remove-if-not '(lambda (x) (equal key (car x))) alist)
      
1486.   )
      
1487. )
      
1488. ;;47 [功能] 曲线是否封闭
      
1489. ;;(MJ:IsClosed (car (entsel)))封闭返回T,圆返回nil
      
1490. (defun MJ:IsClosed (epl / vpl)
      
1491.   (setq vpl (MJ:MakeObject epl));转换成Vla
      
1492.   (if (vlax-property-available-p vpl 'Closed)
      
1493.     (= (vlax-get-property vpl 'Closed) :vlax-true)
      
1494.   )
      
1495. )
      
1496. ;;48 [功能] 返回一个包涵经过pt点的多段线端点的列表
      
1497. ;; Returns a list containing the endpoints of the selected lwpoly segment
      
1498. ;; 示例: (apply 'MJ:GetPolySegment (list (car (entsel)) (getpoint)))返回((-1600.24 2403.92) (-1524.08 2403.92))
      
1499. (defun MJ:GetPolySegment (poly pt / pts i)
      
1500.   (setq pts (MJ:Massoc 10 (entget poly))
      
1501. i   (caddar (ssnamex (ssget pt)))
      
1502.   )
      
1503.   (list
      
1504.     (nth (1- i) pts)
      
1505.     (if
      
1506.       (and
      
1507. (MJ:IsClosed poly)
      
1508. (= i (length pts))
      
1509.       )
      
1510.        (car pts)
      
1511.        (nth i pts)
      
1512.     )     
      
1513.   )
      
1514. )
      
1515. ;;49 [功能] 把弧变成圆
      
1516. (defun MJ:CloseArc (/ arcent arcobj trapobj circ)
      
1517.   (while (setq arcent (entsel "\nSelect ARC object: "))
      
1518.     (setq arcobj (MJ:MakeObject (car arcent)))
      
1519.     (cond
      
1520.       ((= "AcDbArc" (MJ:ObjectType arcobj))
      
1521.        (MJ:UndoBegin)
      
1522.        (setq circ
      
1523.        (vla-addCircle
      
1524.   *MS*
      
1525.   (vla-Get-center arcobj)
      
1526.   (vla-Get-radius arcobj)
      
1527.        )
      
1528.        )
      
1529.        (MJ:MapPropertyList
      
1530.   '("Layer" "Color" "Thickness" "Linetype" "LinetypeScale")
      
1531.   arcobj
      
1532.   circ
      
1533.        )
      
1534.        (MJ:DeleteObject arcobj)
      
1535.        (vlax-Release-Object circ)
      
1536.        (MJ:UndoEnd)
      
1537.       )     ;
      
1538.       (T (princ "\nNot an ARC object, try again..."))
      
1539.     )     ; cond
      
1540.   )     ; endwhile
      
1541.   (princ)
      
1542. )
      
1543. ;;50.1 [功能] 线型是否存在?
      
1544. ;;示例: (MJ:Ltype-Exists-p "DASHED") (MJ:Ltype-Exists-p "continuous")
      
1545. (defun MJ:Ltype-Exists-p (strLtype)
      
1546.   (member
      
1547.     (strcase strLtype)
      
1548.     (mapcar 'strcase (MJ:ListLtypes))
      
1549.   )
      
1550. )
      
1551. ;;50.2 [功能] 改变vla对象线型
      
1552. ;; 示例: (MJ:Apply-Ltype cirobj "DASHED")改变对象线型
      
1553. (defun MJ:Apply-Ltype (obj strLtype / entlist)
      
1554.   (cond
      
1555.     ((MJ:Ltype-Exists-p strLtype)
      
1556.      (cond
      
1557.        ((and
      
1558.    (vlax-Read-Enabled-p obj)   
      
1559.    (vlax-Write-Enabled-p obj)  
      
1560. )
      
1561. (vla-Put-Linetype obj strLtype)
      
1562. T
      
1563.        )   
      
1564.        (T (princ "\n Unable to modify object!"))
      
1565.      )
      
1566.     )   
      
1567.     (T
      
1568.      (princ (strcat "\n Linetype ["
      
1569.       strLtype
      
1570.       "] not loaded."
      
1571.      )
      
1572.      )
      
1573.     )
      
1574.   )   
      
1575. )
      
1576. ;;51.1 [功能] 角度->弧度
      
1577. (defun MJ:D2R (a) (* pi (/ a 180.0)))
      
1578. ;;51.2 [功能] 弧度->角度
      
1579. (defun MJ:R2D (a) (/ (* a 180.0) pi))
      
1580. ;;52.1 [功能] 3D点->2D点 By Caoyin
      
1581. (defun 3dpoint->2dpoint (3dpt)
      
1582.   (if (apply 'and (mapcar 'numberp 3dpt))
      
1583.     (mapcar '+ 3dpt '(0. 0.))
      
1584.   )
      
1585. )
      
1586. ;;52.2 [功能] 3D点->2D点
      
1587. (defun 3d->2d (3dpt / 2dpt)
      
1588.   (setq 2dpt (list (car 3dpt) (cadr 3dpt)))
      
1589. )
      
1590. ;;52.3 [功能] 3D点列表->2D点列表
      
1591. (defun 3dpoint-list->2dpoint-list (3dplist / 2dplist)
      
1592.   (cond
      
1593.     ((and 3dplist (listp 3dplist) (listp (car 3dplist)))
      
1594.      (setq 2dplist
      
1595.      (mapcar '(lambda (pt) (list (car pt) (cadr pt))) 3dplist)
      
1596.      )
      
1597.     )
      
1598.     (T
      
1599.      (princ
      
1600.        "\n3dpoint-list->2dpoint-list: Invalid parameter list..."
      
1601.      )
      
1602.     )
      
1603.   )
      
1604. )
      
1605. ;;52.4 [功能] 3D点列表->2D点列表
      
1606. (defun 3dlist->2dlist (3dplist)
      
1607.   (mapcar '3d->2d 3dplist)
      
1608. )
      
1609. ;;52.5 [功能] 对表分段
      
1610. ;;(xl_div lst nom)表分段. -> 返回 分段的表.   －－－－－－by 无痕.2004.1
      
1611. ; lst ＝ 表，nom = 分段的子表元素个数(从1开始计).
      
1612. ;;示例 (xl_div '(1 2 3 4 5 6 7 8 9) 3) -> ((1 2 3) (4 5 6) (7 8 9))
      
1613. (defun xl-div (lst x / lst2)
      
1614.   (foreach n lst
      
1615.     (if (and lst2 (/= x (length (car lst2))))
      
1616.       (setq lst2 (cons (append (car lst2) (list n)) (cdr lst2)))
      
1617.       (setq lst2 (cons (list n) lst2))
      
1618.     )
      
1619.   )
      
1620.   (reverse lst2)
      
1621. )
      
1622. ;;53.1 [功能] 画线
      
1623. ;; 示例:(MJ:AddLine (getpoint) (getpoint) nil nil nil)
      
1624. (defun MJ:AddLine (StartPt EndPt strLayer intColor strLtype / obj)
      
1625.   (cond
      
1626.     ((and StartPt (listp StartPt) EndPt (listp EndPt))
      
1627.      (setq obj (vla-addLine
      
1628.    (vla-Get-ModelSpace
      
1629.      *DOC*
      
1630.    )
      
1631.    (vlax-3D-Point StartPt)
      
1632.    (vlax-3D-Point EndPt)
      
1633.         )
      
1634.      )
      
1635.      (cond
      
1636.        ((vlax-Write-Enabled-p obj)
      
1637. (if strLayer
      
1638.    (vla-Put-Layer obj strLayer)
      
1639. )
      
1640. (if intColor
      
1641.    (vla-Put-Color obj intColor)
      
1642. )
      
1643. (if strLtype
      
1644.    (MJ:Apply-Ltype obj strLtype)
      
1645. )
      
1646. (vla-Update obj)
      
1647. (vlax-Release-Object obj)
      
1648. (entlast)
      
1649.        )   
      
1650.        (T (princ "\nUnable to modify object properties..."))
      
1651.      )
      
1652.     )     
      
1653.     (T (princ "\nMJ:AddLine: Invalid parameter list..."))
      
1654.   )
      
1655. )
      
1656. ;;53.2 [功能] 根据点表画线
      
1657. (defun MJ:AddLineC (ptlist Bclosed strLayer intColor strLtype / *MJ:MODELSPACE* PT1 PTZ)
      
1658.   (setq *MJ:ModelSpace* *MS*)
      
1659.   (cond
      
1660.     ((and ptlist (listp ptlist) (listp (car ptlist)))
      
1661.      (setq pt1 (car ptlist)
      
1662.     ;; save first point
      
1663.     ptz (last ptlist)
      
1664.         ;; save last point
      
1665.      )
      
1666.      (while (and ptlist (>= (length ptlist) 2))
      
1667.        (MJ:AddLine
      
1668.   *MJ:ModelSpace*
      
1669.   (car ptlist)
      
1670.   (cadr ptlist)
      
1671.   strLayer
      
1672.   intColor
      
1673.   strLtype
      
1674.        )
      
1675.        (setq ptlist (cdr ptlist))
      
1676.      )
      
1677.      (if (= Bclosed T)
      
1678.        (MJ:AddLine
      
1679.   *MJ:ModelSpace* pt1 ptz strLayer intColor strLtype)
      
1680.      )
      
1681.     )
      
1682.     (T (princ "\nMakeLineC: Invalid parameter list..."))
      
1683.   )
      
1684. )
      
1685. ;;54 [功能] 画弧
      
1686. ;; 示例: (MJ:AddArc pt1 0.5 0 90 "0" 3 "DASHED")
      
1687. (defun MJ:AddArc
      
1688.      (CenterPt   Radius   StartAng   EndAng
      
1689.       strLayer   intColor   strLtype   /
      
1690.       obj
      
1691.      )
      
1692.   (cond
      
1693.     ((and CenterPt (listp CenterPt) Radius StartAng EndAng)
      
1694.      (setq obj
      
1695.      (vla-addArc
      
1696.        (vla-Get-ModelSpace
      
1697.   *DOC*
      
1698.        )
      
1699.        (vlax-3D-Point CenterPt)
      
1700.        Radius
      
1701.        (MJ:D2R StartAng)
      
1702.        (MJ:D2R EndAng)
      
1703.      )
      
1704.      )
      
1705.      (cond
      
1706.        ((vlax-Write-Enabled-p obj)
      
1707. (if strLayer
      
1708.    (vla-Put-Layer obj strLayer)
      
1709. )
      
1710. (if intColor
      
1711.    (vla-Put-Color obj intColor)
      
1712. )
      
1713. (if strLtype
      
1714.    (MJ:Apply-Ltype obj strLtype)
      
1715. )
      
1716. (vla-Update obj)
      
1717. (vlax-Release-Object obj)
      
1718. (entlast)
      
1719.        )    ;
      
1720.        (T (princ "\nUnable to modify object properties..."))
      
1721.      )
      
1722.     )     ;
      
1723.     (T (princ "\nMJ:AddArc: Invalid parameter list..."))
      
1724.   )     
      
1725. )
      
1726. ;;55 [功能] 画圆
      
1727. ;; 示例: (MJ:AddCircle pt1 0.5 "0" 3 "DASHED")
      
1728. (defun MJ:AddCircle
      
1729.        (CenterPt Radius strLayer intColor strLtype / obj)
      
1730.   (cond
      
1731.     ((and CenterPt (listp CenterPt) Radius)
      
1732.      (setq obj (vla-addCircle
      
1733.    (vla-Get-ModelSpace
      
1734.      *DOC*
      
1735.    )
      
1736.    (vlax-3D-Point CenterPt)
      
1737.    Radius
      
1738.         )
      
1739.      )
      
1740.      (cond
      
1741.        ((vlax-Write-Enabled-p obj)
      
1742. (if strLayer
      
1743.    (vla-Put-Layer obj strLayer)
      
1744. )
      
1745. (if intColor
      
1746.    (vla-Put-Color obj intColor)
      
1747. )
      
1748. (if strLtype
      
1749.    (MJ:Apply-Ltype obj strLtype)
      
1750. )
      
1751. (vla-Update obj)
      
1752. (vlax-Release-Object obj)
      
1753. (entlast)
      
1754.        )
      
1755.        (T (princ "\nUnable to modify object properties..."))
      
1756.      )
      
1757.     )
      
1758.     (T (princ "\nMJ:AddCircle: Invalid parameter list..."))
      
1759.   )
      
1760. )
      
1761. ;;56 [功能] 画多段线
      
1762. ;; EXMAPLE: (MJ:AddPline  ptlist "0" T 3 "DASHED" 0.125)   ;;
      
1763. (defun MJ:AddPline
      
1764.        (ptlist strLayer  Bclosed   intColor  strLtype
      
1765.         dblWidth /   vrtcs     lst       plgen
      
1766.         plist plpoints  obj
      
1767.        )
      
1768.   (cond
      
1769.     ((and ptlist (listp ptlist) (listp (car ptlist)))
      
1770.      (setq plist    (apply 'append (mapcar '3dpoint->2dpoint ptlist))
      
1771.     plpoints (MJ:List->VariantArray plist)
      
1772.     obj     (vla-AddLightWeightPolyline
      
1773.         (vla-Get-ModelSpace
      
1774.    *DOC*
      
1775.         )
      
1776.         plpoints
      
1777.       )
      
1778.      )
      
1779.      (cond
      
1780.        ((and
      
1781.    (vlax-Read-Enabled-p obj)
      
1782.    (vlax-Write-Enabled-p obj)
      
1783. )
      
1784. (if Bclosed
      
1785.    (vla-Put-Closed obj :vlax-True)
      
1786. )
      
1787. (if strLayer
      
1788.    (vla-Put-Layer obj strLayer)
      
1789. )
      
1790. (if intColor
      
1791.    (vla-Put-Color obj intColor)
      
1792. )
      
1793. (if dblWidth
      
1794.    (vla-Put-ConstantWidth obj dblWidth)
      
1795. )
      
1796. (if strLtype
      
1797.    (progn
      
1798.      (MJ:Apply-Ltype obj strLtype)
      
1799.      (vla-Put-LinetypeGeneration obj :vlax-True)
      
1800.    )
      
1801. )
      
1802. (vla-Update obj)
      
1803. (vlax-Release-Object obj)
      
1804. (entlast)
      
1805.        )
      
1806.        (T (princ "\n Unable to modify object!"))
      
1807.      )
      
1808.     )
      
1809.     (T (princ "\n Invalid parameter list...."))
      
1810.   )
      
1811. )
      
1812. ;;56.1 [功能] 画椭圆
      
1813. ;; 示例: (MJ:AddEllipse l1 p2 45 "PARTS" nil nil)     ;;
      
1814. (defun MJ:AddEllipse
      
1815.        (ctr hmpt roll strLayer intColor strLtype / lst obj)
      
1816.   (cond
      
1817.     ((and ctr (listp ctr) hmpt (listp hmpt) roll)
      
1818.      (setq hmpt (list
      
1819.     (- (car hmpt) (car ctr))
      
1820.     (- (cadr hmpt) (cadr ctr))
      
1821.   )
      
1822.     obj (vla-addEllipse
      
1823.     *MS*
      
1824.     (vlax-3D-Point ctr)
      
1825.     (vlax-3D-Point hmpt)
      
1826.     (cos (MJ:D2R roll))
      
1827.   )
      
1828.      )
      
1829.      (cond
      
1830.        ((vlax-Write-Enabled-p obj)
      
1831. (if strLayer
      
1832.    (vla-Put-Layer obj strLayer)
      
1833. )
      
1834. (if intColor
      
1835.    (vla-Put-Color obj intColor)
      
1836. )
      
1837. (if strLtype
      
1838.    (MJ:Apply-Ltype obj strLtype)
      
1839. )
      
1840. (vla-Update obj)
      
1841.        )   
      
1842.        (T (princ "\nUnable to modify object properties..."))
      
1843.      )     
      
1844.      (vlax-Release-Object obj)
      
1845.      (entlast)
      
1846.     )     
      
1847.     (T (princ "\nInvalid paprameter list..."))
      
1848.   )     
      
1849. )
      
1850. ;;56.2 [功能] 画椭圆弧
      
1851. (defun MJ:AddEllipseArc1
      
1852.       (ctr      hmpt     roll     StartAng
      
1853.        EndAng   strLayer intColor strLtype
      
1854.        /      obj      rang
      
1855.       )
      
1856.   (cond
      
1857.     ((and ctr (listp ctr) hmpt roll)
      
1858.      (setq hmpt (list
      
1859.     (- (car hmpt) (car ctr))
      
1860.     (- (cadr hmhp) (cadr ctr))
      
1861.   )
      
1862.     obj (vla-addEllipse
      
1863.     *MS*
      
1864.     (vlax-3D-Point ctr)
      
1865.     (vlax-3D-Point hmpt)
      
1866.     (MJ:Roll->Ratio roll)
      
1867.   )
      
1868.      )
      
1869.      (cond
      
1870.        ((vlax-Write-Enabled-p obj)
      
1871. (vla-Put-StartAngle obj (MJ:D2R StartAng))
      
1872. (vla-Put-EndAngle obj (MJ:D2R EndAng))
      
1873. (if strLayer
      
1874.    (vla-Put-Layer obj strLayer)
      
1875. )
      
1876. (if intColor
      
1877.    (vla-Put-Color obj intColor)
      
1878. )
      
1879. (if strLtype
      
1880.    (MJ:Apply-Ltype obj strLtype)
      
1881. )
      
1882. (vla-Update obj)
      
1883. (vlax-Release-Object obj)
      
1884. (entlast)
      
1885.        )   
      
1886.        (T (princ "\nUnable to modify object properties..."))
      
1887.      )   
      
1888.     )   
      
1889.     (T (princ "\nMakeArcEllipse1: Invalid parameter list..."))
      
1890.   )     
      
1891. )
      
1892. ;;56.3 [功能] 画椭圆弧
      
1893. (defun MJ:AddEllipseArc2
      
1894.       (ctr      hmpt     hmin     StartAng
      
1895.        EndAng   strLayer intColor strLtype
      
1896.        /      obj      rang
      
1897.       )
      
1898.   (cond
      
1899.     ((and ctr (listp ctr) hmpt (listp hmpt) hmin)
      
1900.      (setq hmpt (list
      
1901.     (- (car hmpt) (car ctr))
      
1902.     (- (cadr hmpt) (cadr ctr))
      
1903.   )
      
1904.     obj (vla-addEllipse
      
1905.     *MS*
      
1906.     (vlax-3D-Point ctr)
      
1907.     (vlax-3D-Point hmpt)
      
1908.     hmin
      
1909.   )
      
1910.      )
      
1911.      (cond
      
1912.        ((vlax-Write-Enabled-p obj)
      
1913. (vla-Put-StartAngle obj (MJ:D2R StartAng))
      
1914. (vla-Put-EndAngle obj (MJ:D2R EndAng))
      
1915. (if strLayer
      
1916.    (vla-Put-Layer obj strLayer)
      
1917. )
      
1918. (if intColor
      
1919.    (vla-Put-Color obj intColor)
      
1920. )
      
1921. (if strLtype
      
1922.    (MJ:Apply-Ltype obj strLtype)
      
1923. )
      
1924. (vla-Update obj)
      
1925. (vlax-Release-Object obj)
      
1926. (entlast)
      
1927.        )   
      
1928.        (T (princ "\nUnable to modify object properties..."))
      
1929.      )   
      
1930.     )     
      
1931.     (T (princ "\nMakeArcEllipse2: Invalid parameter list..."))
      
1932.   )     
      
1933. )
      
1934. ;;57 [功能] 生成一个点
      
1935. ;; 示例: (MJ:AddPoint p1 nil)
      
1936. (defun MJ:AddPoint (pt strLayer / obj)
      
1937.   (cond
      
1938.     ((and pt (listp pt))
      
1939.      (setq obj (vla-addPoint *MS* (vlax-3D-Point pt)))
      
1940.      (if (vlax-Write-Enabled-p obj)
      
1941.        (progn
      
1942.   (if strLayer
      
1943.     (vla-Put-Layer obj strLayer)
      
1944.   )
      
1945.   (vla-Update obj)
      
1946.   (vlax-Release-Object obj)
      
1947.   (entlast)
      
1948.        )
      
1949.        (princ "\nMJ:AddPoint: Unable to modify object!")
      
1950.      )     
      
1951.     )     
      
1952.     (T (princ "\nMJ:AddPoint: Invalid parameter list..."))
      
1953.   )     
      
1954. )
      
1955. ;;58 [功能] 单行文字
      
1956. ;; 示例:    (MJ:AddText "ABC" p1 "MC" "STANDARD" 0.25 1.0 0 "TEXT" nil)
      
1957. (defun MJ:AddText
      
1958.       (strTxt   pt       Just strStyle dblHgt
      
1959.        dblWid   dblRot   strLay intCol  /
      
1960.        txtobj
      
1961.       )
      
1962.   (cond
      
1963.     ((setq txtobj
      
1964.      (vla-AddText
      
1965.        (MJ:ActiveSpace)
      
1966.        strTxt
      
1967.        (if (not (member (strcase Just) '("A" "F")))
      
1968.   (vlax-3d-Point pt)
      
1969.   (vlax-3d-Point (car pt))
      
1970.        )    ; endif
      
1971.        dblHgt
      
1972.        ;; ignored if Just = "A" (aligned)
      
1973.      )
      
1974.      )
      
1975.      (vla-put-StyleName txtobj strStyle)
      
1976.      (vla-put-Layer txtobj strLay)
      
1977.      (if intCol
      
1978.        (vla-put-Color txtobj intCol)
      
1979.      )
      
1980.      (setq Just (strcase Just))
      
1981.      ;; force to upper case for comparisons...
      
1982.      ;; Left/Align/Fit/Center/Middle/Right/BL/BC/BR/ML/MC/MR/TL/TC/TR
      
1983.      ;; Note that "Left" is not a normal default.
      
1984.      ;;
      
1985.      ;; ALIGNMENT TYPES...
      
1986.      ;; AcAlignmentLeft=0
      
1987.      ;; AcAlignmentCenter=1
      
1988.      ;; AcAlignmentRight=2
      
1989.      ;; AcAlignmentAligned=3
      
1990.      ;; AcAlignmentMiddle=4
      
1991.      ;; AcAlignmentFit=5
      
1992.      ;; AcAlignmentTopLeft=6
      
1993.      ;; AcAlignmentTopCenter=7
      
1994.      ;; AcAlignmentTopRight=8
      
1995.      ;; AcAlignmentMiddleLeft=9
      
1996.      ;; AcAlignmentMiddleCenter=10
      
1997.      ;; AcAlignmentMiddleRight=11
      
1998.      ;; AcAlignmentBottomLeft=12
      
1999.      ;; AcAlignmentBottomCenter=13
      
2000.      ;; AcAlignmentBottomRight=14
      
2001.      ;;                                                               
      
2002.      ;; HORIZONTAL JUSTIFICATIONS...                                 
      
2003.      ;; AcHorizontalAlignmentLeft=0                                   
      
2004.      ;; AcHorizontalAlignmentCenter=1                                 
      
2005.      ;; AcHorizontalAlignmentRight=2                                 
      
2006.      ;; AcHorizontalAlignmentAligned=3                                
      
2007.      ;; AcHorizontalAlignmentMiddle=4                                 
      
2008.      ;; AcHorizontalAlignmentFit=5                                    
      
2009.      ;;                                                               
      
2010.      ;; VERTICAL JUSTIFICATIONS...                                    
      
2011.      ;; AcVerticalAlignmentBaseline=0                                 
      
2012.      ;; AcVerticalAlignmentBottom=1                                   
      
2013.      ;; AcVerticalAlignmentMiddle=2                                   
      
2014.      ;; AcVerticalAlignmentTop=3                                      
      
2015.      (cond
      
2016.        ((= Just "L")
      
2017. ;; Left
      
2018. (vla-put-ScaleFactor txtobj dblWid)
      
2019. (vla-put-Rotation txtobj (DTR dblRot))
      
2020.        )
      
2021.        ((= Just "C")
      
2022. ;; Center
      
2023. (vla-put-Alignment txtobj 1)
      
2024. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2025. (vla-put-ScaleFactor txtobj dblWid)
      
2026. (vla-put-Rotation txtobj (DTR dblRot))
      
2027.        )
      
2028.        ((= Just "R")
      
2029. ;; Right
      
2030. (vla-put-Alignment txtobj 2)
      
2031. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2032. (vla-put-ScaleFactor txtobj dblWid)
      
2033. (vla-put-Rotation txtobj (DTR dblRot))
      
2034.        )
      
2035.        ((= Just "A")
      
2036. ;; Alignment
      
2037. (vla-put-Alignment txtobj 3)
      
2038. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2039.        )
      
2040.        ((= Just "M")
      
2041. ;; Middle
      
2042. (vla-put-Alignment txtobj 4)
      
2043. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2044. (vla-put-ScaleFactor txtobj dblWid)
      
2045. (vla-put-Rotation txtobj (DTR dblRot))
      
2046.        )
      
2047.        ((= Just "F")
      
2048. ;; Fit
      
2049. (vla-put-Alignment txtobj 5)
      
2050. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2051.        )
      
2052.        ((= Just "TL")
      
2053. ;; Top-Left
      
2054. (vla-put-Alignment txtobj 6)
      
2055. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2056. (vla-put-ScaleFactor txtobj dblWid)
      
2057. (vla-put-Rotation txtobj (DTR dblRot))
      
2058.        )
      
2059.        ((= Just "TC")
      
2060. ;; Top-Center
      
2061. (vla-put-Alignment txtobj 7)
      
2062. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2063. (vla-put-ScaleFactor txtobj dblWid)
      
2064. (vla-put-Rotation txtobj (DTR dblRot))
      
2065.        )
      
2066.        ((= Just "TR")
      
2067. ;; Top-Right
      
2068. (vla-put-Alignment txtobj 8)
      
2069. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2070. (vla-put-ScaleFactor txtobj dblWid)
      
2071. (vla-put-Rotation txtobj (DTR dblRot))
      
2072.        )
      
2073.        ((= Just "ML")
      
2074. ;; Middle-Left
      
2075. (vla-put-Alignment txtobj 9)
      
2076. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2077. (vla-put-ScaleFactor txtobj dblWid)
      
2078. (vla-put-Rotation txtobj (DTR dblRot))
      
2079.        )
      
2080.        ((= Just "MC")
      
2081. ;; Middle-Center
      
2082. (vla-put-Alignment txtobj 10)
      
2083. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2084. (vla-put-ScaleFactor txtobj dblWid)
      
2085. (vla-put-Rotation txtobj (DTR dblRot))
      
2086.        )
      
2087.        ((= Just "MR")
      
2088. ;; Middle-Right
      
2089. (vla-put-Alignment txtobj 11)
      
2090. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2091. (vla-put-ScaleFactor txtobj dblWid)
      
2092. (vla-put-Rotation txtobj (DTR dblRot))
      
2093.        )
      
2094.        ((= Just "BL")
      
2095. ;; Bottom-Left
      
2096. (vla-put-Alignment txtobj 12)
      
2097. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2098. (vla-put-ScaleFactor txtobj dblWid)
      
2099. (vla-put-Rotation txtobj (DTR dblRot))
      
2100.        )
      
2101.        ((= Just "BC")
      
2102. ;; Bottom-Center
      
2103. (vla-put-Alignment txtobj 13)
      
2104. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2105. (vla-put-ScaleFactor txtobj dblWid)
      
2106. (vla-put-Rotation txtobj (DTR dblRot))
      
2107.        )
      
2108.        ((= Just "BR")
      
2109. ;; Bottom-Right
      
2110. (vla-put-Alignment txtobj 14)
      
2111. (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
      
2112. (vla-put-ScaleFactor txtobj dblWid)
      
2113. (vla-put-Rotation txtobj (DTR dblRot))
      
2114.        )
      
2115.      )
      
2116.      (vla-Update txtobj)
      
2117.      (vlax-Release-Object txtobj)
      
2118.      (entlast)
      
2119.     )   
      
2120.   )   
      
2121. )
      
2122. ;;59 [功能] 画多边形
      
2123. ;; (MJ:AddPolygon center, radius, sides, flag, width, layer, color, ltype)
      
2124. ;; 示例: (MJ:AddPolygon pt1 1.0 6 nil 0 "0" nil "DASHED")
      
2125. (defun MJ:AddPolygon
      
2126.          (ctrpt  dblRad   intSides strType  dblWid
      
2127.    strLay  intCol   strLtype /     pa
      
2128.    dg  ptlist   deg
      
2129.          )
      
2130.   (setq pa  (polar ctrpt 0 dblRad)
      
2131. dg  (/ 360.0 intSides)
      
2132. ;; get angles between faces
      
2133. deg dg
      
2134.   )
      
2135.   (repeat intSides
      
2136.     (setq ptlist
      
2137.     (if ptlist
      
2138.       (append ptlist (list (polar ctrpt (MJ:D2R deg) dblRad)))
      
2139.       (list (polar ctrpt (MJ:D2R deg) dblRad))
      
2140.     )
      
2141.     )
      
2142.     (setq deg (+ dg deg))
      
2143.   )     ; repeat
      
2144.   (MJ:AddPline ptlist strLay T intCol strLtype dblWid)
      
2145. )
      
2146. ;;60 [功能] 画矩形
      
2147. ;; (MJ:AddRectangle p1(lower left), p3(upper right), layer, color, linetype, width)
      
2148. ;; 示例: (MJ:AddRectangle p1 p3 "0" nil "DASHED" 0.25)
      
2149. (defun MJ:AddRectangle
      
2150.        (p1 p3 strLayer intColor strLtype dblWid / p2 p4 obj)
      
2151.   (setq p2 (list (car p1) (cadr p3))
      
2152. p4 (list (car p3) (cadr p1))
      
2153.   )
      
2154.   (cond
      
2155.     ((setq obj (MJ:AddPline
      
2156.    (list p1 p2 p3 p4)
      
2157.    strLayer
      
2158.    T
      
2159.    intColor
      
2160.    strLtype
      
2161.    dblWidth
      
2162.         )
      
2163.      )
      
2164.      obj
      
2165.      ;; raise object (entity name)
      
2166.     )
      
2167.   )   
      
2168. )
      
2169. ;;61 [功能] 画长方体
      
2170. ;; (MJ:AddSolid points-list, layer(string), color(integer))
      
2171. ;; 示例: (MJ:AddSolid ptlist "0" nil)
      
2172. (defun MJ:AddSolid (ptlist strLayer intColor / plist obj)
      
2173.   (cond
      
2174.     ((and ptlist (listp ptlist) (listp (car ptlist)))
      
2175.      (if (= (length ptlist) 3)
      
2176.        (setq plist (append ptlist (list (last ptlist))))
      
2177.        (setq plist ptlist)
      
2178.      )   
      
2179.      (cond
      
2180.        ((setq obj (vla-addSolid
      
2181.       (MJ:ActiveSpace)
      
2182.       (vlax-3D-Point (car plist))
      
2183.       (vlax-3D-Point (cadr plist))
      
2184.       (vlax-3D-Point (caddr plist))
      
2185.       (vlax-3D-Point (cadddr plist))
      
2186.     )
      
2187. )
      
2188. (if strLayer
      
2189.    (vla-Put-Layer obj strLayer)
      
2190. )
      
2191. (if intColor
      
2192.    (vla-Put-Color obj intColor)
      
2193. )
      
2194. (vla-Update obj)
      
2195. (vlax-release-object obj)
      
2196. (entlast)
      
2197.        )    ;
      
2198.        (T (princ "\nUnable to create object..."))
      
2199.      )     ; cond
      
2200.     )     ;
      
2201.     (T (princ "\nMJ:AddSolid: Invalid parameter list..."))
      
2202.   )     
      
2203. )
      
2204. ;;62 [功能] 多行文字MText
      
2205. (defun myMText (txtString coner Width)
      
2206.   (vla-addText *MS* (vlax-3d-point pt) Width txtString)
      
2207. )
      
2208. ;;63 [功能] 面域Region
      
2209. (defun myRegion (curveObjList nColor / CN CURVES REGIONOBJ)
      
2210.   (setq cn (length curveObjList))
      
2211.   (setq curves (vlax-make-safearray vlax-vbObject (cons 0 (1- cn))))
      
2212.   (vlax-safearray-fill curves curveObjList)
      
2213.   (setq RegionObj (vla-AddRegion *MS* curves))
      
2214.   (vla-put-color
      
2215.     (vla-safearray-get-element (vla-Variant-value RegionObj) 0)
      
2216.     nColor
      
2217.   )
      
2218. )
      
2219. ;;64 [功能] 对象外画一矩形
      
2220. ;; 示例:   (MJ:DrawVpBorder (car (entsel)))              ;;
      
2221. ;; Notes:     1. The return value is the entity name of the newly created lwpolyline     ;;
      
2222. ;;            2. The layout containing the viewport to be drawn must be active   ;;
      
2223. (defun MJ:DrawVpBorder (vp / ll ur coords pl)
      
2224.   (vl-load-com)  
      
2225.   (setq vp (vlax-ename->vla-object vp))
      
2226.   (vla-GetBoundingBox vp 'll 'ur)
      
2227.   (setq ll (vlax-safearray->list ll)
      
2228. ur (vlax-safearray->list ur)
      
2229.   )
      
2230.   (setq coords (vlax-safearray-fill
      
2231.    (vlax-make-safearray vlax-vbDouble (cons 0 7))
      
2232.    (list (nth 0 ll);x
      
2233.          (nth 1 ll);y
      
2234.          (nth 0 ur);x
      
2235.          (nth 1 ll);y
      
2236.          (nth 0 ur)
      
2237.          (nth 1 ur)
      
2238.          (nth 0 ll)
      
2239.          (nth 1 ur)
      
2240.    )
      
2241.         )
      
2242.   )
      
2243.   (vla-put-closed
      
2244.     (setq pl (vla-AddLightWeightPolyline
      
2245.         (vla-get-ModelSpace (vla-get-Document vp))
      
2246.         coords
      
2247.       )
      
2248.     )
      
2249.     :vlax-true
      
2250.   )
      
2251.   (*Obj2En* pl)
      
2252. )
      
2253. ;;65.1 [功能] 创建图层(成功返回层名)
      
2254. ;;(MJ:DefineLayer strName intColor strLtype booleCur)
      
2255. ;; 示例: (MJ:DefineLayer "MJ:Layer1" 3 "DASHED" T)
      
2256. (defun MJ:DefineLayer
      
2257.        (strName intColor strLtype booleCur / iloc obj out)
      
2258.   (cond
      
2259.     ((not (tblsearch "layer" strName))
      
2260.      (setq obj (vla-add (*LAYS*) strName))
      
2261.      (setq iloc (vl-position strName (MJ:ListLayers)))
      
2262.      (cond
      
2263.        ((vlax-Write-Enabled-p obj)
      
2264. (if intColor
      
2265.    (vla-put-Color obj intColor)
      
2266. )
      
2267. (if strLtype
      
2268.    (MJ:Apply-Ltype obj strLtype)
      
2269. )
      
2270.        )
      
2271.        (T (princ "\nUnable to modify object properties..."))
      
2272.      )     
      
2273.      (if booleCur
      
2274.        (vla-put-ActiveLayer
      
2275.   *DOC*
      
2276.   (vla-Item (*LAYS*) iloc)
      
2277.        )
      
2278.      )
      
2279.      (setq out strName)
      
2280.     )
      
2281.     (T
      
2282.      (princ (strcat "\nLayer already exists: " strName))
      
2283.     )
      
2284.   )
      
2285.   out
      
2286. )
      
2287. ;;65.2 [功能] 创建一个图层(新建层不为当前层)
      
2288. ;; 示例:   (MJ:MakeLayer "A-Wall")
      
2289. (defun MJ:MakeLayer (lName / oLayer)  
      
2290.   (if
      
2291.     (vl-catch-all-error-p
      
2292.       (setq oLayer
      
2293.       (vl-catch-all-apply
      
2294.         'vla-add
      
2295.         (list
      
2296.    *LAYS*
      
2297.    lName
      
2298.         )
      
2299.       )
      
2300.       )
      
2301.     )
      
2302.      nil
      
2303.      oLayer
      
2304.   )
      
2305. )
      
2306. ;;66.1 [功能] 表->变体数组类型
      
2307. (defun MJ:DblList->VariantArray (nList / ArraySpace sArray)
      
2308.   ;; allocate space for an array of 2d points stored as doubles
      
2309.   (setq ArraySpace
      
2310.   (vlax-Make-SafeArray
      
2311.     vlax-vbDouble
      
2312.     (cons 0
      
2313.    (- (length nList) 1)
      
2314.     )
      
2315.   )
      
2316.   )
      
2317.   (setq sArray (vlax-SafeArray-Fill ArraySpace nList))
      
2318.   (vlax-Make-Variant sArray)
      
2319. )
      
2320. ;;66.2 [功能] 表->整数数组
      
2321. (defun MJ:IntList->VarArray (aList)
      
2322.   (vlax-SafeArray-Fill
      
2323.     (vlax-Make-SafeArray
      
2324.       vlax-vbInteger   ; (2) Integer
      
2325.       (cons 0 (- (length aList) 1))
      
2326.     )
      
2327.     aList
      
2328.   )
      
2329. )
      
2330. ;;66.3 [功能] 表->变体数组
      
2331. (defun MJ:VarList->VarArray (aList)
      
2332.   (vlax-SafeArray-Fill
      
2333.     (vlax-Make-SafeArray
      
2334.       vlax-vbVariant   ;(12) Variant
      
2335.       (cons 0 (- (length aList) 1))
      
2336.     )
      
2337.     aList
      
2338.   )
      
2339. )
      
2340. ;;66.4 [功能] 选择集->数组
      
2341. (defun SS->Array (ss / c r)
      
2342.   (vl-load-com)
      
2343.   (setq c -1)
      
2344.   (repeat (sslength ss)
      
2345.     (setq r (cons (ssname ss (setq c (1+ c))) r))
      
2346.   )
      
2347.   (setq r (reverse r))
      
2348.   (vlax-safearray-fill
      
2349.     (vlax-make-safearray
      
2350.       vlax-vbObject;根据需要使用其类型
      
2351.       (cons 0 (1- (length r)))
      
2352.     )
      
2353.     (mapcar 'vlax-ename->vla-object r)
      
2354.   )
      
2355. )
      
2356. ;;66.5 [功能] 列表->变体数组
      
2357. ;; 示例:   (setq ptlist (list "1" 2 (list 1.0 2.0 3.0)))
      
2358. ;;(MJ:list->VariantArray (apply 'append ptlist) vlax-vbDouble)
      
2359. ;; Notes:     1. If your list includes various data types, pass vlax-vbVariant for the
      
2360. ;;               varType argument
      
2361. ;;        2. Entity names are converted to ObjectIDs
      
2362. ;;        3. To convert a point list to ActiveX coordinates:
      
2363. (defun MJ:list->VariantArray (lst varType)  
      
2364.   (vlax-make-variant
      
2365.     (vlax-safearray-fill
      
2366.       (vlax-make-safearray
      
2367. varType
      
2368. (cons 0 (1- (length lst)))
      
2369.       )
      
2370.       (mapcar
      
2371. '(lambda (x)
      
2372.     (cond
      
2373.       ((= (type x) 'list)
      
2374.        (vlax-safearray-fill
      
2375.   (vlax-make-safearray
      
2376.     (if (apply '= (mapcar 'type x))
      
2377.       (cond
      
2378.         ((= (type (car x)) 'REAL) vlax-vbDouble)
      
2379.         ((= (type (car x)) 'INT) vlax-vbInteger)
      
2380.         ((= (type (car x)) 'STR) vlax-vbString)
      
2381.       )
      
2382.       vlax-vbVariant
      
2383.     )
      
2384.     (cons 0 (1- (length x)))
      
2385.   )
      
2386.   x
      
2387.        )
      
2388.       )
      
2389.       ((= (type x) 'ename)
      
2390.        (vla-get-objectid (*En2Obj* x))
      
2391.       )
      
2392.       (t x)
      
2393.     )
      
2394.   )
      
2395. lst
      
2396.       )
      
2397.     )
      
2398.   )
      
2399. )
      
2400. ;;67 [功能] 对象端点列表
      
2401. ;; 示例:(MJ:GetEllipseArcPoints (car (entsel)))返回两端点
      
2402. (defun MJ:GetEllipseArcPoints
      
2403.        (ellent / OUT P-END P-START VLAOBJECT-ELLIPSE)
      
2404.   (setq vlaObject-Ellipse (MJ:MakeObject ellent)
      
2405. ;; convert ename to object
      
2406. p-start    (vla-Get-StartPoint vlaObject-Ellipse)
      
2407. p-end    (vla-Get-EndPoint vlaObject-Ellipse)
      
2408. out    (list
      
2409.        (vlax-SafeArray->List (vlax-Variant-Value p-start))
      
2410.        (vlax-SafeArray->List (vlax-Variant-Value p-end))
      
2411.      )
      
2412.   )
      
2413.   out
      
2414. )
      
2415. ;;68 [功能] 更改Vla对象线型比例
      
2416. ;; 示例: (MJ:Apply-LtScale objLine 24.0)
      
2417. (defun MJ:Apply-LtScale (obj dblLtScale)
      
2418.   (cond
      
2419.     ((and
      
2420.        (vlax-Read-Enabled-p obj)      
      
2421.        (vlax-Write-Enabled-p obj)      
      
2422.      )
      
2423.      (vla-Put-Linetype dblLtScale)
      
2424.      T     
      
2425.     )   
      
2426.     (T (princ "\n Unable to modify object!"))
      
2427.   )   
      
2428. )
      
2429. ;;69 [功能] 将图层集合中的第一个图层设置为当前层
      
2430. (defun MJ:LayZero ()
      
2431.   (vla-put-ActiveLayer
      
2432.     *DOC*
      
2433.     (vla-Item (*LAYS*) 0)
      
2434.   )
      
2435. )
      
2436. ;;70 [功能] 设置指定层为当前层
      
2437. ;; (MJ:LayActive "DIM")相当于(command "clayer" "DIM")
      
2438. (defun MJ:LayActive (name / iloc out)
      
2439.   (cond
      
2440.     ((and
      
2441.        (tblsearch "layer" name)
      
2442.        (setq iloc (vl-Position name (MJ:ListLayers)))
      
2443.      )
      
2444.      (vla-put-ActiveLayer
      
2445.        *DOC*
      
2446.        (vla-Item (*LAYS*) iloc)
      
2447.      )
      
2448.      (setq out name)
      
2449.     )     
      
2450.     (T (princ (strcat "\n Layer not defined: " name)))
      
2451.   )   
      
2452.   out
      
2453. )
      
2454. ;;71.1图层列表 开
      
2455. (defun MJ:LayerOn (LayList)
      
2456.   (vlax-for each (vla-get-layers *DOC*)
      
2457.     (if (member (strcase (vla-get-name each)) LayList)
      
2458.       (if (vlax-write-enabled-p each)
      
2459. (vla-put-LayerOn each :vlax-True)
      
2460.       )
      
2461.     )
      
2462.     (vlax-release-object each)
      
2463.   )
      
2464. )
      
2465. ;;71.2 [功能] 图层列表 关
      
2466. (defun MJ:LayerOff (LayList)
      
2467.   (vlax-for each (*LAYS*)
      
2468.     (if (member (strcase (vla-get-name each)) LayList)
      
2469.       (if (vlax-write-enabled-p each)
      
2470. (vla-put-LayerOn each :vlax-False)
      
2471.       )
      
2472.     )
      
2473.     (vlax-release-object each)
      
2474.   )
      
2475. )
      
2476. ;;71.3 [功能] 图层列表 冻结
      
2477. (defun MJ:LayerFreeze (LayList)
      
2478.   (vlax-for each (*LAYS*)
      
2479.     (if (member (strcase (vla-get-name each)) LayList)
      
2480.       (if (vlax-write-enabled-p each)
      
2481. (vla-put-Freeze each :vlax-True)
      
2482.       )
      
2483.     )
      
2484.     (vlax-release-object each)
      
2485.   )
      
2486. )
      
2487. ;;71.4 [功能] 图层列表 解冻
      
2488. (defun MJ:LayerThaw (LayList)
      
2489.   (vlax-for each (*LAYS*)
      
2490.     (if (member (strcase (vla-get-name each)) LayList)
      
2491.       (if (vlax-write-enabled-p each)
      
2492. (vla-put-Freeze each :vlax-False)
      
2493.       )
      
2494.     )
      
2495.     (vlax-release-object each)
      
2496.   )
      
2497. )
      
2498. ;;71.5 [功能] 图层列表[打印/不打印]
      
2499. ;; 示例: (MJ:LayerNoPlot '("DOORS" "WINDOWS") T)设置图层不打印
      
2500. ;; 示例: (MJ:LayerNoPlot '("DOORS" "WINDOWS") nil) 设置图层打印
      
2501. (defun MJ:LayerNoPlot (LayList On-Off)
      
2502.   (vlax-for each (*LAYS*)
      
2503.     (if (member (strcase (vla-get-name each)) LayList)
      
2504.       (if (vlax-write-enabled-p each)
      
2505. (if On-Off
      
2506.    (vla-put-Plottable each :vlax-True)
      
2507.    (vla-put-Plottable each :vlax-False)
      
2508. )
      
2509.       )
      
2510.     )
      
2511.     (vlax-release-object each)
      
2512.   )
      
2513. )
      
2514. ;;71.6 [功能] 图层列表 锁
      
2515. (defun MJ:LayerLock (LayList)
      
2516.   (vlax-for each (*LAYS*)
      
2517.     (if (member (strcase (vla-get-name each)) LayList)
      
2518.       (if (vlax-write-enabled-p each)
      
2519. (vla-put-Lock each :vlax-True)
      
2520.       )
      
2521.     )
      
2522.     (vlax-release-object each)
      
2523.   )
      
2524. )
      
2525. ;;71.7 [功能] 图层列表 解锁
      
2526. (defun MJ:LayerUnLock (LayList)
      
2527.   (vlax-for each (*LAYS*)
      
2528.     (if (member (strcase (vla-get-name each)) LayList)
      
2529.       (if (vlax-write-enabled-p each)
      
2530. (vla-put-Lock each :vlax-False)
      
2531.       )
      
2532.     )
      
2533.     (vlax-release-object each)
      
2534.   )
      
2535. )
      
2536. ;;71.8 [功能] 锁定图层列表
      
2537. (defun MJ:ListLayers-Locked (/ each out)
      
2538.   (vlax-for each (*LAYS*)
      
2539.     (if (= (vlax-get-property each "Lock") :vlax-true)
      
2540.       (setq out (cons (vla-get-name each) out))
      
2541.     )
      
2542.   )
      
2543.   out
      
2544. )
      
2545. ;;71.9 [功能] 返回冻结图层列表
      
2546. (defun MJ:ListLayers-Frozen (/ each out)
      
2547.   (vlax-for each (*LAYS*)
      
2548.     (if (= (vlax-get-property each "Freeze") :vlax-true)
      
2549.       (setq out (cons (vla-get-name each) out))
      
2550.     )
      
2551.   )
      
2552.   out
      
2553. )
      
2554. ;;71.10 [功能] 返回关闭图层列表
      
2555. (defun MJ:ListLayers-Off (/ each out)
      
2556.   (vlax-for each (*LAYS*)
      
2557.     (if (= (vlax-get-property each "LayerOn") :vlax-false)
      
2558.       (setq out (cons (vla-get-name each) out))
      
2559.     )
      
2560.   )
      
2561.   out
      
2562. )
      
2563. ;;71.11 [功能] 可打印图层列表
      
2564. (defun MJ:ListLayers-Plottable (/ each out)
      
2565.   (vlax-for each (*LAYS*)
      
2566.     (if (= (vlax-get-property each "Plottable") :vlax-true)
      
2567.       (setq out (cons (vla-get-name each) out))
      
2568.     )
      
2569.   )
      
2570.   out
      
2571. )
      
2572. ;;71.12 [功能] 非打印图层列表
      
2573. (defun MJ:ListLayers-Plottalbe-Not (/ each out)
      
2574.   (vlax-for each (*LAYS*)
      
2575.     (if (= (vlax-get-property each "Plottable") :vlax-false)
      
2576.       (setq out (cons (vla-get-name each) out))
      
2577.     )
      
2578.   )
      
2579.   out
      
2580. )
      
2581. ;;71.13 [功能] 层是否冻结？
      
2582. ;;(MJ:Layer-Frozen-p "DIM")
      
2583. (defun MJ:Layer-Frozen-p (lname / each)
      
2584.   (if
      
2585.     (and
      
2586.       (setq fl (MJ:ListLayers-Frozen))
      
2587.       ;; any frozen layers?
      
2588.       (member (strcase lname) (mapcar 'strcase fl))
      
2589.     )
      
2590.      T
      
2591.   )
      
2592. )
      
2593. ;;71.14 [功能] 解冻 解锁 开 所有图层
      
2594. (defun MJ:Mylayer ()
      
2595.   (acet-layerp-mark nil)
      
2596.   (acet-layerp-mode T)
      
2597.   (acet-layerp-mark T)
      
2598.   (command "_.Layer" "Thaw" "*" "U" "*" "ON" "*" "")
      
2599. )
      
2600. ;;71.15 [功能] 恢复图层状态  By coaying
      
2601. (defun MJ:layer-restore ()
      
2602.   (acet-layerp-mark nil)
      
2603.   (command "_.layerp")
      
2604. )
      
2605. ;;71.16 [功能] 得到图层状态highflybird
      
2606. (defun Get_Layer_Status (/ V_LIST L_LIST C_LIST T_LIST W_LIST *DOC)
      
2607.   (setq *Doc (vla-get-ActiveDocument (vlax-get-acad-object)))
      
2608.   (vlax-for n (vla-get-layers *DOC)
      
2609.     (setq V_List (cons (cons n (vla-get-LayerOn n)) V_List)
      
2610.    L_List (cons (cons n (vla-get-Lock n)) L_List)
      
2611.    C_List (cons (cons n (vla-get-TrueColor n)) C_List)
      
2612.    T_List (cons (cons n (vla-get-Linetype n)) T_List)
      
2613.    W_List (cons (cons n (vla-get-LineWeight n)) W_List)
      
2614.    F_List (cons (cons n (vla-get-Freeze n)) F_List)
      
2615.     )
      
2616.   )
      
2617.   (List V_List L_List C_List T_List W_List F_List)
      
2618. )
      
2619. ;;71.17 [功能] 恢复图层状态highflybird
      
2620. (defun Restore_Layer_status (LayLst)
      
2621.   (mapcar (function
      
2622.      (lambda (x y)
      
2623.        (foreach n X
      
2624.   (if (/= (strcase (setq name (vla-get-name (car n))))
      
2625.    (strcase (getvar "clayer"))
      
2626.       )   ; 非当前层
      
2627.     (vlax-put-property (car n) y (cdr n))
      
2628.     ;;对于当前层
      
2629.     (if (/= y "Freeze") ; 排除冻结操作，以防出错
      
2630.       (vlax-put-property (car n) y (cdr n))
      
2631.     )
      
2632.   )
      
2633.        )
      
2634.      )
      
2635.    )
      
2636.    LayLst
      
2637.    (list "Layeron"      "Lock"       "TrueColor"
      
2638.   "LineType"     "LineWeight"   "Freeze"
      
2639.         )
      
2640.   )
      
2641.   ;;(vl-cmdf "regen")
      
2642. )
      
2643. ;;71.18 [功能] 图层是否锁定?
      
2644. ;;(b_layer_locked "0"),0层锁后返回T
      
2645. (defun b_layer_locked (la / na e1)
      
2646.   (setq na (tblobjname "layer" la)
      
2647. e1 (entget na)
      
2648.   )
      
2649.   (equal 4 (logand 4 (cdr (assoc 70 e1))))
      
2650. )
      
2651. ;;72 [功能] 设置vla对象线宽
      
2652. ;; NOTES:
      
2653. ;;   "ByLwDefault" = -3
      
2654. ;;   "ByBlock" = -2
      
2655. ;;   "ByLayer" = -1
      
2656. ;;   Other values are 0, 5, 9, 13, 15, 18, 20, 25, 30, 35, 40, 50, 53, 60,
      
2657. ;;   70, 80, 90, 100, 106, 120, 140, 158, 200, 211
      
2658. (defun MJ:SetLweight (obj intLwt)
      
2659.   (cond
      
2660.     ((member intLwt
      
2661.       '(0    5  9    13   15 18   20   25   30   35  40
      
2662.         50   60  70   80   90 100  106  120  140  158  200
      
2663.         211
      
2664.        )
      
2665.      )
      
2666.      (vla-put-LineWeight obj ineLwt)
      
2667.      T     
      
2668.     )
      
2669.   )   
      
2670. )
      
2671. ;;73 [功能] vla选择集是否存在
      
2672. (defun MJ:SSetExists-p (Name)
      
2673.   (not
      
2674.     (vl-Catch-All-Error-p
      
2675.       (vl-Catch-All-Apply
      
2676. 'vla-Item
      
2677. (list (vla-Get-SelectionSets *DOC*) Name)
      
2678.       )
      
2679.     )
      
2680.   )
      
2681. )
      
2682. ;;74.1 [功能] 返回指定类型的选择集
      
2683. ;; 示例: (setq MJ:set (MJ:SelectByType "CIRCLE"))
      
2684. ;;(MJ:MapCollection MJ:set 'MJ:DeleteObject)圆全部删除
      
2685. (defun MJ:SelectByType (objtype / ss)
      
2686.   (if (MJ:SSetExists-p "%TEMP_SET")
      
2687.     (vla-Delete
      
2688.       (vla-Item
      
2689. (vla-get-SelectionSets *DOC*)
      
2690. "%TEMP_SET"
      
2691.       )
      
2692.     )
      
2693.   )
      
2694.   (setq ss
      
2695.   (vla-Add
      
2696.     (vla-get-SelectionSets *DOC*)
      
2697.     "%TEMP_SET"
      
2698.   )
      
2699.   )
      
2700.   (vla-Select
      
2701.     ss
      
2702.     ACSelectionSetAll
      
2703.     nil
      
2704.     nil
      
2705.     (MJ:IntList->VarArray (list 0))
      
2706.     (MJ:VarList->VarArray (list objtype))
      
2707.   )
      
2708.   ss
      
2709. )
      
2710. ;;74.2 [功能] 返回指定类型的选择集
      
2711. ;; MODULE: (MJ:SelectOnScreen-Filter GroupCodes FilterLists)
      
2712. ;;示例见下
      
2713. (defun MJ:SelectOnScreen-Filter (GroupCodes FilterLists / ss)
      
2714.   (if (MJ:SSetExists-p "%TEMP_SET")
      
2715.     (vla-Delete
      
2716.       (vla-Item
      
2717. (vla-get-SelectionSets *DOC*)
      
2718. "%TEMP_SET"
      
2719.       )
      
2720.     )
      
2721.   )
      
2722.   (setq ss
      
2723.   (vla-Add
      
2724.     (vla-get-SelectionSets *DOC*)
      
2725.     "%TEMP_SET"
      
2726.   )
      
2727.   )
      
2728.   (vla-Select
      
2729.     ss
      
2730.     ACSelectionSetAll
      
2731.     nil
      
2732.     nil
      
2733.     (MJ:IntList->VarArray GroupCodes)
      
2734.     (MJ:VarList->VarArray FilterLists)
      
2735.   )
      
2736.   ss
      
2737. )
      
2738. ;;74.3 [功能] 返回0层上的圆选择集
      
2739. (defun MJ:PICKCIRCLES (/ SS)
      
2740.   (if
      
2741.     (setq ss (MJ:SelectOnScreen-Filter '(0 8) '("CIRCLE" "0")))
      
2742.      (vlax-For item ss
      
2743.        (princ (vla-get-ObjectName item))
      
2744.        (terpri)
      
2745.      )
      
2746.   )   
      
2747.   (terpri)
      
2748.   ss
      
2749. )
      
2750. ;;74.4 [功能] 返回圆选择集(并打印名称)
      
2751. (defun C:GETCIRCLES ()
      
2752.   (if (setq ss (MJ:SelectByType "CIRCLE"))
      
2753.     (vlax-For item ss
      
2754.       (princ (vla-get-ObjectName item))
      
2755.       (terpri)
      
2756.     )
      
2757.   )
      
2758.   ss
      
2759. )
      
2760. ;;75.1 [功能] 返回CAD窗口状态
      
2761. ;; acEnum 1=Min 2=Normal 3=Max
      
2762. ;; 示例: (MJ:GetWindowState) return 1, 2 or 3
      
2763. (defun MJ:GetWindowState ()
      
2764.   (vla-get-WindowState *ACAD*)
      
2765. )
      
2766. ;;75.2 [功能] 设置CAD窗口状态
      
2767. ;; 示例: (MJ:SetWindowState 3) maximizes the window display
      
2768. (defun MJ:SetWindowState (acEnum)
      
2769.   (vla-put-WindowState *ACAD* acEnum)
      
2770. )
      
2771. ;;76.1 [功能] 隐藏CAD
      
2772. ;; 示例: (MJ:HideAutoCAD)
      
2773. (defun MJ:HideAutoCAD ()
      
2774.   (vla-put-Visible *ACAD* :vlax-False)
      
2775. )
      
2776. ;;76.2 [功能] 显示CAD
      
2777. ;; 示例: (MJ:ShowAutoCAD)
      
2778. (defun MJ:ShowAutoCAD ()
      
2779.   (vla-put-Visible *ACAD* :vlax-True)
      
2780. )
      
2781. ;;76.3 [功能] 隐藏CAD一段时间
      
2782. ;; 示例: (MJ:HideShowTest 500) 隐藏CAD，时间500毫秒
      
2783. (defun MJ:HideShowTest (delay-time)
      
2784.   (MJ:HideAutoCAD)  
      
2785.   (vl-cmdf "delay" delay-time)  
      
2786.   (MJ:ShowAutoCAD)  
      
2787. )
      
2788. 
      
2789. ;;77.1 [功能] CAD参数选择
      
2790. (defun MJ:DocPrefs ()
      
2791.   (vla-get-Preferences *DOC*)
      
2792. )
      
2793. ;;77.2 [功能] 线宽显示
      
2794. (defun MJ:LWdisplayON ()
      
2795.   (vla-put-LineWeightDisplay (MJ:DocPrefs) :vlax-True)
      
2796. )
      
2797. ;;77.3 [功能] 隐藏线宽
      
2798. (defun MJ:LWdisplayOFF ()
      
2799.   (vla-put-LineWeightDisplay (MJ:DocPrefs) :vlax-False)
      
2800. )
      
2801. ;;77.4 [功能] 对象捕捉开
      
2802. (defun MJ:ObjectSortBySnapON ()
      
2803.   (vla-put-ObjectSortBySnap (MJ:DocPrefs) :vlax-True)
      
2804. )
      
2805. ;;77.5 [功能] 对象捕捉关闭
      
2806. (defun MJ:ObjectSortBySnapOFF ()
      
2807.   (vla-put-ObjectSortBySnap (MJ:DocPrefs) :vlax-False)
      
2808. )
      
2809. ;;77.6[功能] 图形被其它用户参照时仍可以立即编辑
      
2810. (defun MJ:XrefEditON ()
      
2811.   (vla-put-XrefEdit (MJ:DocPrefs) :vlax-True)
      
2812. )
      
2813. ;;77.7[功能] 图形被其它用户参照时不可以立即编辑
      
2814. (defun MJ:XrefEditOFF ()
      
2815.   (vla-put-XrefEdit (MJ:DocPrefs) :vlax-False)  
      
2816. )
      
2817. ;;78.1 [功能] CAD菜单集合
      
2818. (defun MJ:MenuGroups ()
      
2819.   (vla-get-menugroups *ACAD*)
      
2820. )
      
2821. ;;78.2 [功能] 菜单列表
      
2822. ;;示例("ACAD" "CXinZhi")
      
2823. (defun MJ:MenuGroups-ListAll (/ out)
      
2824.   (vlax-for each (MJ:MenuGroups)
      
2825.     (setq out (cons (vla-get-name each) out))
      
2826.   )
      
2827.   (reverse out)
      
2828. )
      
2829. ;;78.3 [功能] 菜单是否存在
      
2830. ;;示例(MJ:MenuGroup-Exists-p "CXinZhi")返回 1
      
2831. (defun MJ:MenuGroup-Exists-p (name)
      
2832.   (if
      
2833.     (member
      
2834.       (strcase name)
      
2835.       (mapcar 'strcase (MJ:MenuGroups-ListAll))
      
2836.     )
      
2837.      (vl-position name (MJ:MenuGroups-ListAll))
      
2838.   )
      
2839. )
      
2840. ;;78.4 [功能] 工具条Vla集合
      
2841. (defun MJ:Toolbars (mgroup)
      
2842.   (if (MJ:MenuGroup-Exists-p mgroup)
      
2843.     (vla-get-toolbars
      
2844.       (vla-item
      
2845. (MJ:MenuGroups)
      
2846. (vl-position
      
2847.    (strcase mgroup)
      
2848.    (mapcar 'strcase (MJ:MenuGroups-ListAll))
      
2849. )
      
2850.       )
      
2851.     )
      
2852.   )
      
2853. )
      
2854. ;;78.5 [功能] 工具条列表
      
2855. ;;(MJ:ToolbarsList "CXinZhi")返回("附加图层工具" "附加文字工具" "附加标准工具")
      
2856. (defun MJ:ToolbarsList (mgroup / tb out)
      
2857.   (if (setq tb (MJ:Toolbars mgroup))
      
2858.     (vlax-for each tb
      
2859.       (setq out (cons (vla-get-name each) out))
      
2860.     )
      
2861.   )
      
2862.   (reverse out)
      
2863. )
      
2864. ;;78.6 [功能] 工具条列表
      
2865. ;; Arguments: 菜单名称
      
2866. ;; 示例:   (ListToolbars "acad")(ListToolbars "CXinZhi")
      
2867. (defun MJ:ListToolbars (groupName / mGroups mGroup lst)
      
2868.   (if (not
      
2869. (vl-catch-all-error-p
      
2870.    (setq
      
2871.      mGroup (vl-catch-all-apply
      
2872.        'vla-item
      
2873.        (list (vla-get-menugroups *ACAD*)
      
2874.       groupName
      
2875.        )
      
2876.      )
      
2877.    )
      
2878. )
      
2879.       )
      
2880.     (vlax-for tBar (vla-get-toolbars mGroup)
      
2881.       (setq lst (cons (vla-get-name tBar) lst))
      
2882.     )
      
2883.   )
      
2884. )
      
2885. ;;78.7 [功能] 工具条是否存在
      
2886. ;;(MJ:Toolbar-Exists-p "CXinZhi" "附加图层工具");返回0
      
2887. (defun MJ:Toolbar-Exists-p (mgroup tbname)
      
2888.   (if
      
2889.     (and
      
2890.       (MJ:MenuGroup-Exists-p mgroup)
      
2891.       (member
      
2892. (strcase tbname)
      
2893. (mapcar 'strcase (MJ:Toolbars-ListAll mgroup))
      
2894.       )
      
2895.     )
      
2896.      (vl-position tbname (MJ:Toolbars-ListAll mgroup))
      
2897.   )
      
2898. )
      
2899. ;;78.8 [功能] 指定工具条(Vla)
      
2900. (defun MJ:Toolbar (mgroup tbname / loc)
      
2901.   (if (setq loc (MJ:Toolbar-Exists-p mgroup tbname))
      
2902.     (vla-item (MJ:Toolbars mgroup) loc)
      
2903.   )
      
2904. )
      
2905. ;;78.9 [功能] 显示指定工具条
      
2906. ;;(MJ:Toolbar-Show "ACAD" "UCS")将显示UCS工具条
      
2907. ;;(MJ:Toolbar-Show "CXinZhi" "附加图层工具")
      
2908. (defun MJ:Toolbar-Show (mgroup tbname / tb)
      
2909.   (if (setq tb (MJ:Toolbar mgroup tbname))
      
2910.     (if (= (vla-get-visible tb) :vlax-false)
      
2911.       (progn
      
2912. (vla-put-visible tb :vlax-true)
      
2913. T
      
2914.       )
      
2915.     )
      
2916.   )
      
2917. )
      
2918. ;;78.10 [功能] 隐藏工具条
      
2919. (defun MJ:Toolbar-Hide (mgroup tbname / tb)
      
2920.   (if (setq tb (MJ:Toolbar mgroup tbname))
      
2921.     (if (= (vla-get-visible tb) :vlax-true)
      
2922.       (progn
      
2923. (vla-put-visible tb :vlax-false)
      
2924. T
      
2925.       )
      
2926.     )
      
2927.   )
      
2928. )
      
2929. ;;78.11 [功能] 工具条放置位置
      
2930. ;; NOTES: Allowable <dock> values are 0(top), 1(bottom), 2(left),            ;;
      
2931. ;;        and 3(right). Returns 1 if successful, -1 if toolbar is not        ;;
      
2932. ;;        visible, -2 if parameter is invalid, or 0 if toolbar not found.    ;;
      
2933. (defun MJ:Toolbar-Dock (mgroup tbname dock / tb)
      
2934.   (if (setq tb (MJ:Toolbar mgroup tbname))
      
2935.     (if (= (vla-get-visible tb) :vlax-true)
      
2936.       (if (member dock '(0 1 2 3))
      
2937. (progn
      
2938.    (vlax-invoke-method tb 'Dock dock)
      
2939.    1
      
2940. )
      
2941. -2
      
2942. ;; invalid dockstatus parameter
      
2943.       )
      
2944.       -1
      
2945.       ;; toolbar not visible
      
2946.     )
      
2947.     0
      
2948.     ;; toolbar not found
      
2949.   )
      
2950. )
      
2951. ;;78.12 [功能] Float a given toolbar at specified position(top and left)
      
2952. ;;   and display with specified number of rows. Returns 1 if successful,
      
2953. ;;   -1 if toolbar is not visible, 0 if toolbar is not found.
      
2954. (defun MJ:Toolbar-Folat (mgroup tbname top left rows)
      
2955.   (if (setq tb (MJ:Toolbar mgroup tbname))
      
2956.     (if (= (vla-get-visible tb) :vlax-true)
      
2957.       (progn
      
2958. (vlax-invoke-method tb 'Float top left rows)
      
2959. 1
      
2960.       )
      
2961.       -1
      
2962.       ;; toolbar not visible
      
2963.     )
      
2964.     0
      
2965.     ;; toolbar not found
      
2966.   )
      
2967. )
      
2968. ;;78.13 [功能] 改变工具条按钮位图
      
2969. ;; 示例:   (MJ:ChangeBitmap "acad" "dimension" "linear dimension" "test.bmp")
      
2970. ;; Notes:     1. If the bitmap is not in the AutoCAD search path, you must specify      ;;
      
2971. ;;               the full path to file        ;;
      
2972. (defun MJ:ChangeBitmap (mnuGroup tbrName btnName bitmap)
      
2973.   (vl-load-com)
      
2974.   (vla-setbitmaps
      
2975.     (vla-item
      
2976.       (vla-item
      
2977. (vla-get-toolbars
      
2978.    (vla-item (vla-get-menugroups *ACAD*)
      
2979.       mnuGroup
      
2980.    )
      
2981. )
      
2982. tbrName
      
2983.       )
      
2984.       btnName
      
2985.     )
      
2986.     bitmap
      
2987.     bitmap
      
2988.   )
      
2989.   (princ)
      
2990. )
      
2991. ;;79 [功能] 2D点转成vla 2D
      
2992. (defun MJ:2DPoint (pt)
      
2993.   (vl-load-com)
      
2994.   (vlax-make-variant
      
2995.     (vlax-safearray-fill
      
2996.       (vlax-make-safearray vlax-vbdouble '(0 . 1))
      
2997.       (list (car pt) (cadr pt))
      
2998.     )
      
2999.   )
      
3000. )
      
3001. ;;80.1 [功能] 激活最左边一个布局
      
3002. ;;下面程序使用vla-activate有问题,看起来没有错误
      
3003. ;;模型和布局之间自由切换(setvar "CTAB" "layout2")
      
3004. (defun MJ:ActivateLastLayout (/ CNT I)  
      
3005.   (vlax-for layout *LOUTS*
      
3006.     (if (= (vla-get-taborder layout) 1);取得布局的tab顺序,图纸空间的标签（tab）顺序必须是1或大于1
      
3007.       (vla-put-ActiveLayout *DOC* layout) ; (vla-activate layout)运行有问题      
      
3008.     )
      
3009.   )
      
3010. )
      
3011. ;;80.2 [功能] 激活第二个图形[Ctrl+Tab] 见10
      
3012. (defun MJ:ActivateDrawing ()  
      
3013.   (vla-activate (vla-item *docs* 1))
      
3014. )
      

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

自贡黄明儒

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

墙脚哥

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

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

e2002

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

lty

板凳啊！

yoyoho

感谢楼主分享,学习了!

穿靴子的猫

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

yjr111

支持一下，收集辛苦了

652758365

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

smartstar

支持支持！

巛丸

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

xyp1964

才100多个就算多了……