常用函数.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 />

墙脚哥

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

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

wybjy

(defun c:dyfillet()
   (setq p1x 0)
   (setq p1y 0)
   (setq p2x 0)
   (setq p2y 100)
   (setq p3x 100)
   (setq p3y 100)
   (setq p4x 0)
   (setq p4y 50)
   (setq p5x 50)
   (setq p5y 100)

   (setq r 20)

   (setq p1 ( list p1x  p1y ))
   (setq p2 ( list p2x  p2y ))
   (setq p3 ( list p3x  p3y ))
   (setq p4 ( list p4x  p4y ))
   (setq p5 ( list p5x  p5y ))

   (command  "pline" p1 p2 p3 )
   (command   "" )

   (command  "fillet" "R" "" r     p4   p5  )
   (command   "" )      

)
程序运行到下面这行就报错，
(command  "fillet" "R" "" r   p4   p5  )
发现程序运行到  r   就报错了，p4和p5的目的想实现选取对象操作，看来这样是不行的。在CAD命令行输入直线上的点坐标是可以选择直线的，不知道在LISP里面怎么实现这样的操作。请大侠指点一下

e2002

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

lty

板凳啊！

yoyoho

感谢楼主分享,学习了!

穿靴子的猫

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

yjr111

支持一下，收集辛苦了

652758365

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

smartstar

支持支持！

巛丸

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

xyp1964

才100多个就算多了……