明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 163989|回复: 569

[函数] 常用函数.lsp

    [复制链接]
发表于 2012-9-20 16:23:46 | 显示全部楼层 |阅读模式
本帖最后由 自贡黄明儒 于 2022-5-16 13:53 编辑

;;各位,把你们收藏都拿出秀一秀呀,放在箱底会生霉的
;;我的收集是在caoyin发布的通用函数基础上扩展的----自贡黄明儒 2012.9.20
;;有人说,抄一个人的叫偷,抄多个人的叫做研究,如果这种说话真的成立的话,那么我是在进行研究
;;1 [功能] 检查加载vlisp扩展
;;2  常数(lisp编辑器在输出局部变量时,带*的会排在前面.Caoyin这样写很有道理)
;;3 [功能] 返回活动空间vla对象
;;4.1 [功能] 返回当前活动空间名称("Model" or "aper")
;;4.2 [功能] 返回空间名称,如"Model"或者"Layout1"...
;;5 [功能] 返回Preferences vla对象
;;6 [功能] 返回指定引用的属性
;;7 [功能] 更改引用设置
;;8 [功能] 返回 acad对象的属性
;;9 [功能] 对象名称
;;10 [功能] 打开文件名列表
;;11 [功能] 查询对象属性和方法
;;12 [功能] 设置 Qleader 命令“引线设置”对话框的相关参数
;;13 [功能] 求点集中最远,最近点表   ;By 无痕
;;14.1 [功能] 返回指定集合的数量
;;14.2 [功能] 返回文档集合的数量
;;15 [功能] 返回文档指定对象的属性
;;15.1 [功能] 图层集合
;;15.2 [功能] 线型集合
;;15.3 [功能] 文字样式集合
;;15.4 [功能] 尺寸样式集合
;;15.5 [功能] 布局集合
;;15.6 [功能] 词典集合
;;15.7 [功能] 块集合
;;15.8 [功能] 打印配置集合
;;15.9 [功能] 视图集合
;;15.10 [功能] 视口集合
;;15.11 [功能] 组集合
;;15.12 [功能] 注册程序集合
;;16 [功能] 返回集合成员名称列表
;;16.1 [功能] 返回线型集合成员名称列表(常量*LTS*)
;;16.2 [功能] 返回层集合成员名称列表(常量*LAYS*)
;;16.3 [功能] 返回文字样式集合成员名称列表(常量*STS*)
;;16.4 [功能] 返回尺寸样式集合成员名称列表
;;16.5 [功能] 返回布局集合成员名称列表
;;16.6 [功能] 返回词典集合成员名称列表
;;16.7 [功能] 返回块集合成员名称列表
;;16.8 [功能] 返回打印配置集合成员名称列表
;;16.9 [功能] 返回视图集合成员名称列表
;;16.10 [功能] 返回视口集合成员名称列表(同常量*VPS*)
;;16.11 [功能] 返回组集合成员名称列表
;;16.12 [功能] 返回注册程序集合成员名称列表
;;17 [功能] 点表排序(根据x Y 或者Z坐标排序)
;;18 [功能] 集合->列表
;;19 [功能] 线型数量
;;20 [功能] 对集合对象的每个成员执行指定函数的操作
;;20.1 [功能] 显示集合对象每个成员的方法和属性.既然是集合,方法是相同的
;;20.2 [功能] 删除对象
;;21.1 [功能] ename->vla对象
;;21.2 [功能] vla对象->ename
;;22 [功能] 返回对象名称(见9)
;;23.1 编组开始(command "_.undo" "be")
;;23.2 编组结束(command "_.undo" "END")
;;24 [功能] 用一个对象的属性等修改另一个对象的属性
;;24.1 [功能] 用一个对象的'(图层 线型...)修改另一个对象的图层 线型...等
;;25.1 [功能] 配置文件集合
;;25.2 [功能] 设置配置文件
;;25.3 [功能] 重新装载配置文件
;;25.4 [功能] 重启默认配置文件
;;25.5 [功能] 输出配置文件
;;25.6 [功能] 输出配置文件
;;25.7 [功能] 输入配置文件
;;25.8 [功能] 复制配置文件
;;25.9 [功能] 重命名配置文件
;;25.10 [功能] 删除配置文件
;;25.11 [功能] 配置文件是否存在
;;25.12 [功能] 配置文件列表
;;26.1 [功能] 非当前文档,关闭(不保存)
;;27.1 [功能] 保存所有文档
;;27.2 [功能] 活动文档是否已经保存?
;;27.3 [功能] 另存为2K格式
;;27.4 [功能] 另存为R14格式
;;28.1 [功能] 清理打开文档
;;28.2 [功能] 删除未使用的图层,比purge彻底
;;29.1 [功能] 取得选定块的指定属性
;;29.2 [功能] 取得块属性列表
;;29.3 [功能] [功能] 取得块属性列表
;;29.4 [功能] Returns a list of constant attributes tags and their values
;;30.1 [功能] 更改块指定属性
;;30.2 [功能] 更改选定块的指定属性
;;30.3 [功能] 更改块多个属性
;;30.4 [功能] 更改块多个属性
;;31.1 [功能] 返回指定(块名 标记 属性值)的块 选择集
;;31.2 [功能] 返回指定(块名 标记 属性值)的块 选择集
;;32.1 [功能] 更改属性位置
;;32.2 [功能] 更改块属性宽度
;;32.3 [功能] 更改块属性高度
;;33 [功能] 列表块插入点(Y排序)
;;34 [功能] 块集的某一属性,显示块的x(or y z)值
;;35.1 [功能] 块中删除对象
;;35.2 [功能] 块增加对象
;;34 [功能] 返回指定块每一个引用实体名列表
;;35 [功能] 块引用名列表
;;36 [功能] 删除指定名的所有块
;;37 [功能] 块名"BTL"是否存在
;;38 [功能] 块更名
;;39 [功能] 块名例表
;;40 [功能] XRef图块列表
;;41 [功能] 返回名为"bn"的XRef图块实体列表
;;42 [功能] 返回包容点集的最小点最大点列表
;;43.1 [功能] 两点中点
;;43.2 [功能] <起点>,<中点>,<终点>列表  ;By 无痕
;;44 [功能] 求矩形中心
;;45 [功能] 返回封闭曲线质心二维坐标
;;46.1 [功能] 多段线各顶点(见99.3)
;;46.2 [功能] pline,lwpline点坐标表  By 无痕
;;46.3 [功能] 返回包含每一出现在列表中的指定键的cdr(点对的后部分)的列表
;;47 [功能] 曲线是否封闭
;;48 [功能] 返回一个包涵经过pt点的多段线端点的列表
;;49 [功能] 把弧变成圆
;;50.1 [功能] 线型是否存在?
;;50.2 [功能] 改变vla对象线型
;;51.1 [功能] 角度->弧度
;;51.2 [功能] 弧度->角度
;;52.1 [功能] 3D点->2D点 By Caoyin
;;52.2 [功能] 3D点->2D点
;;52.3 [功能] 3D点列表->2D点列表
;;52.4 [功能] 3D点列表->2D点列表
;;52.5 [功能] 对表分段
;;53.1 [功能] 画线
;;53.2 [功能] 根据点表画线
;;54 [功能] 画弧
;;55 [功能] 画圆
;;56 [功能] 画多段线
;;56.1 [功能] 画椭圆
;;56.2 [功能] 画椭圆弧
;;56.3 [功能] 画椭圆弧
;;57 [功能] 生成一个点
;;58 [功能] 单行文字
;;59 [功能] 画多边形
;;60 [功能] 画矩形
;;61 [功能] 画长方体
;;62 [功能] 多行文字MText
;;63 [功能] 面域Region
;;64 [功能] 对象外画一矩形
;;65.1 [功能] 创建图层(成功返回层名)
;;65.2 [功能] 创建一个图层(新建层不为当前层)
;;66.1 [功能] 表->变体数组类型
;;66.2 [功能] 表->整数数组
;;66.3 [功能] 表->变体数组
;;66.4 [功能] 选择集->数组
;;66.5 [功能] 列表->变体数组
;;67 [功能] 对象端点列表
;;68 [功能] 更改Vla对象线型比例
;;69 [功能] 将图层集合中的第一个图层设置为当前层
;;70 [功能] 设置指定层为当前层
;;71.1图层列表 开
;;71.2 [功能] 图层列表 关
;;71.3 [功能] 图层列表 冻结
;;71.4 [功能] 图层列表 解冻
;;71.5 [功能] 图层列表 [打印/不打印]
;;71.6 [功能] 图层列表 锁
;;71.7 [功能] 图层列表 解锁
;;71.8 [功能] 锁定图层列表
;;71.9 [功能] 返回冻结图层列表
;;71.10 [功能] 返回关闭图层列表
;;71.11 [功能] 可打印图层列表
;;71.12 [功能] 非打印图层列表
;;71.13 [功能] 层是否冻结?
;;71.14 [功能] 解冻 解锁 开 所有图层
;;71.15 [功能] 恢复图层状态  By coaying
;;71.16 [功能] 得到图层状态highflybird
;;71.17 [功能] 恢复图层状态highflybird
;;71.18 [功能] 图层是否锁定?
;;72 [功能] 设置vla对象线宽
;;73 [功能] vla选择集是否存在
;;74.1 [功能] 返回指定类型的选择集
;;74.2 [功能] 返回指定类型的选择集
;;74.3 [功能] 返回0层上的圆选择集
;;74.4 [功能] 返回圆选择集(并打印名称)
;;75.1 [功能] 返回CAD窗口状态
;;75.2 [功能] 设置CAD窗口状态
;;76.1 [功能] 隐藏CAD
;;76.2 [功能] 显示CAD
;;76.3 [功能] 隐藏CAD一段时间
;;77.1 [功能] CAD参数选择
;;77.2 [功能] 线宽显示
;;77.3 [功能] 隐藏线宽
;;77.4 [功能] 对象捕捉开
;;77.5 [功能] 对象捕捉关闭
;;77.6 [功能] 图形被其它用户参照时仍可以立即编辑
;;77.7 [功能] 图形被其它用户参照时不可以立即编辑
;;78.1 [功能] CAD菜单集合
;;78.2 [功能] 菜单列表
;;78.3 [功能] 菜单是否存在
;;78.4 [功能] 工具条Vla集合
;;78.5 [功能] 工具条列表
;;78.6 [功能] 工具条列表
;;78.7 [功能] 工具条是否存在
;;78.8 [功能] 指定工具条(Vla)
;;78.9 [功能] 显示指定工具条
;;78.10 [功能] 隐藏工具条
;;78.11 [功能] 工具条放置位置
;;78.12 [功能] Float a given toolbar at specified position(top and left)
;;78.13 [功能] 改变工具条按钮位图
;;79 [功能] 2D点转成vla 2D
;;80 [功能] 激活最左边一个布局
;;81 [功能] VLA选择集过滤条件
;;81 [功能] 类型库智能化加载
;;82 [功能] 转换路径中字符 "/" 为 "\\" 并返回大写值
;;83 [功能] 通过IE 显示一个 HTML 字符串
;;84.1 [功能] 显示时间/日期对话框
;;84.2 [功能] Returns the logical drive letter to which a network share is mapped
;;84.3 [功能] 返回驱动器类型
;;84.4 [功能] 返回驱动器列表
;;84.5 [功能] 修改本地磁盘的卷标
;;84.6 [功能] 执行 DOS DELTREE 命令
;;84.7 [功能] 创建目录
;;84.8 [功能] 复制文件或目录
;;84.9 [功能] 复制目录下所有文件和目录
;;84.10 [功能] 移动文件或目录
;;84.11 [功能] 重命名文件或目录
;;84.12 [功能] 返回磁盘的类型
;;84.13 [功能] 返回当前的磁盘表
;;84.14 [功能] 返回磁盘的所有信息
;;84.15 [功能] 返回文件的特定信息
;;84.16 [功能] 返回磁盤的所有信息
;;84.17 [功能] 读文本文件到表 (快于 AutoLISP read-line函数)
;;84.18 [功能] 将字符串或表写入文件 (快于 AutoLISP write-line函数)
;;84.19 [功能] 目录浏览对话框
;;84.20 [功能] 显示 windows 的确认对话框包括图标和可选按钮
;;84.21 [功能] 当前目录文件搜索. 类似于 DIR /S 命令
;;84.22 [功能] 合并两个文本文件
;;85.1 [功能] 字符串分割为表  By 无痕
;;85.2 [功能] 字符串分割为表 -------梁雄啸.2004.3
;;85.3 [功能] 字符串分割为表 (纯autolspl的写法)-----梁雄啸.2004.3
;;85.4 [功能] 字符串分割为表
;;85.5 [功能] 字符串分割成表
;;85.6 [功能] 字符串函数   by qjchen@gmail.com
;;85.7 [功能] 用分隔符解释字符串成表 ;by fsxm
;;85.8 [功能] 字符串分割(这是highflybird问答我的求助)
;;86.1 [功能] Exports the specified project to disk
;;86.2 [功能] Imports a project exported by MJ:ExportProject
;;87.1 [功能] 包围对象最小最大点列表
;;87.2  选择集的实体外矩形框 by gxl
;;88 [功能] 返回曲线长度(不能返回块中曲线长度)
;;89 [功能] Returns the size of the specified file in bytes
;;90.1 [功能] 返回文字样式字体高度
;;90.2 [功能] 设置文字样式字体高度
;;91 [功能] Returns the LISP value of an ActiveX variant
;;92.1 [功能] Attach Extended Entity Data to an AutoCAD object
;;92.2 [功能] Get Extended Entity Data attached to an AutoCAD object
;;93 [功能] 面积标注
;;94 [功能] 重命名布局
;;95 [功能] 返回打开文件列表
;;96 [功能] 返回布局列表
;;97 [功能] 窗口左下角空间切换是否显示
;;98.1 [功能] 模型空间背景色在空白之间切换
;;98.2 [功能] 布局空间背景色在空白之间切换
;;99.1 [功能] 表->二维表
;;99.2 [功能] 表->三维表
;;99.3 [功能] 获取多段线顶点列表(见46)
;;99.4 [功能] 两对象交点
;;100.1 [功能] 判断是否val对象?
;;100.2 [功能] 判断是否字符串
;;100.3 [功能] 判断是否实数?
;;100.4 [功能] 判断是否ename对象?
;;100.5 [功能] 判断是否变体?
;;100.6 [功能] 判断 X 是否是选择集且长度不为 0
;;101 [功能] 多段线顶点的连续样式产生线型
;;102.1 [功能] 使对象颜色随层
;;102.2 [功能] 设置当前颜色
;;103 [功能] 打印配置
;;104 [功能] 打印设备列表
;;105.1 [功能] 清除所有捕捉,与按F3有不同处(参见77.4)
;;105.2 [功能] MJ:SnapOn之后下面函数只启用端点捕捉
;;106 [功能] 打开一个文件
;;107.1 [功能] 原位复制Vla
;;107.2 [功能] 原位复制ename
;;107.3 [功能] 原位置复制VLA选集
;;107.4 [功能] 删除VLA选择集
;;107.5 [功能] 块内原地复制 By xshrimp
;;107.6 [功能] 块内原地复制 by highflybird
;;107.7 [功能] 块内原地复制 by GSLS(SS)
;;108 [功能] 输出 WMF SAT EPS DXF BMP格式文件
;;109 [功能] 移动Move
;;110 [功能] 偏移
;;111 [功能] 退出Acad
;;112 [功能] 重生成
;;113 [功能] 旋转
;;114.1 [功能] 多段线添加节点Vertex
;;114.2 [功能] 多段线修改节点Vertex
;;115 [功能] 文件名已经保存,返回T;新建一文件,未命名保存过,返回 nil
;;116.1 [功能] 缩放整个图形
;;116.2 [功能] 缩放到实际范围
;;116.3 [功能] pt中心点缩放1
;;116.4 [功能] pt中心点缩放2
;;116.5 [功能] 两点窗口缩放
;;116.6 [功能] 视口比例缩放-放大2倍
;;116.7 [功能] 视口比例缩放
;;116.8 [功能] 返回上一视图
;;117.1 [功能] 在当前视图状况下将图形单位转换为像素
;;117.2 [功能] 返回当前视窗左下角和右上角 坐标
;;117.3 [功能] pickbox大小
;;118 [功能] 获取 0~1 之间的随机数 (by zml84)
;;119.1 [功能] 将 ACI 索引颜色转换成 RGB 配色系统
;;119.2 [功能] 将 RGB 配色系统转换成 ACI 索引颜色
;;120.1 [功能] 选择集->图元列表
;;120.2 [功能] 选择集->图元列表 By caiqs
;;120.3 [功能] 图元列表->选择集
;;120.4 [功能] 图元列表->选择集 By caiqs
;;121 [功能] 根据当前文档的图形单位精度将实数转换为字符串
;;122.1 [功能] 遍历选择集对所包含的图元进行指定函数操作
;;122.2 [功能] 遍历选择集对所包含的图元进行指定函数操作
;;123 [功能] 获取当前 AutoCAD 的版本
;;124 [功能] 获取 DXF 组码值
;;125.1 [功能] 获取在图元 en 之后产生的图元列表
;;125.2 [功能] 获取在图元 en 之后产生的图元的选择集
;;126 [功能] 打印列表中的数据
;;127 [功能] 更新组码
;;128.1 [功能] 选择集->无名块
;;128.2 [功能] 用 [选择集/obj表] 做成一个块
;;128.3 [功能] 选择集做成一个块
;;129.1 [功能] 删除表中相同图元
;;129.2 [功能] 剔除表元素 By 无痕
;;130 [功能] 获得特定符号表的列表
;;131.1 [功能] 返回a在表lst中的位置 or nil
;;131.2 [功能] 从列表中删除指定的元素
;;132 [功能] 关键字a的列表框增加内容
;;133.1 [功能] 旋转一个点
;;133.2 [功能] 缩放一个点
;;134.1 [功能] 返回文件名(带扩展名) (反findfile)
;;134.2 [功能] 去文件名扩展,比如去掉.exe
;;134.3 [功能] 分割文件名为三部分
;;135 [功能] p1是否在p2 p3线上
;;136 [功能] 亮显选择集或对象(夹点不显示) 函数
;;137.1 [功能] 获得图形中倒数第二个图元的函数
;;137.2 [功能] 图中最后图元Find True last entity
;;138.1 [功能] 读取指定文件中指定行的内容
;;138.2 [功能] 返回文件行数量
;;138.3 [功能] 读取文件并按行将文件转换为表
;;139 [功能] 用 [选择集/obj表] 做成一个组
;;140 [功能] 加载幻灯片
;;141 [功能] 点表排序
;;142 [功能] 选择集相减 By 自贡黄明儒
;;143.1 [功能]选择集SS排序->图元列表 By 自贡黄明儒
;;143.2 [功能]选择集排序->选择集 By 自贡黄明儒
;;144.1 [功能] 读取系统剪贴板中字符串
;;144.2 [功能] 向系统剪贴板写入文字
;;145 [功能] 求多段线上的弧段(圆或圆弧也有效)的圆心
;;146 [功能] 质心
;;147.1 [功能] 自定义max By yjr111
;;147.2 [功能] 自定义max By G版
;;148.1 [功能] 根据点表画多段线
;;148.2 [功能] 根据点表画多段线
;;148.3 [功能] 根据点表画样条曲线
;;149.1 [功能] 进程显示
;;149.2 [功能] 进程显示
;;150 [功能] 生成无名组
;;151 [功能] 曲线选集长度求和--陌生人.2004.1
;;152 [功能] 局部更新

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

  2786. ;;77.1 [功能] CAD参数选择
  2787. (defun MJ:DocPrefs ()
  2788.   (vla-get-Preferences *DOC*)
  2789. )
  2790. ;;77.2 [功能] 线宽显示
  2791. (defun MJ:LWdisplayON ()
  2792.   (vla-put-LineWeightDisplay (MJ:DocPrefs) :vlax-True)
  2793. )
  2794. ;;77.3 [功能] 隐藏线宽
  2795. (defun MJ:LWdisplayOFF ()
  2796.   (vla-put-LineWeightDisplay (MJ:DocPrefs) :vlax-False)
  2797. )
  2798. ;;77.4 [功能] 对象捕捉开
  2799. (defun MJ:ObjectSortBySnapON ()
  2800.   (vla-put-ObjectSortBySnap (MJ:DocPrefs) :vlax-True)
  2801. )
  2802. ;;77.5 [功能] 对象捕捉关闭
  2803. (defun MJ:ObjectSortBySnapOFF ()
  2804.   (vla-put-ObjectSortBySnap (MJ:DocPrefs) :vlax-False)
  2805. )
  2806. ;;77.6[功能] 图形被其它用户参照时仍可以立即编辑
  2807. (defun MJ:XrefEditON ()
  2808.   (vla-put-XrefEdit (MJ:DocPrefs) :vlax-True)
  2809. )
  2810. ;;77.7[功能] 图形被其它用户参照时不可以立即编辑
  2811. (defun MJ:XrefEditOFF ()
  2812.   (vla-put-XrefEdit (MJ:DocPrefs) :vlax-False)  
  2813. )
  2814. ;;78.1 [功能] CAD菜单集合
  2815. (defun MJ:MenuGroups ()
  2816.   (vla-get-menugroups *ACAD*)
  2817. )
  2818. ;;78.2 [功能] 菜单列表
  2819. ;;示例("ACAD" "CXinZhi")
  2820. (defun MJ:MenuGroups-ListAll (/ out)
  2821.   (vlax-for each (MJ:MenuGroups)
  2822.     (setq out (cons (vla-get-name each) out))
  2823.   )
  2824.   (reverse out)
  2825. )
  2826. ;;78.3 [功能] 菜单是否存在
  2827. ;;示例(MJ:MenuGroup-Exists-p "CXinZhi")返回 1
  2828. (defun MJ:MenuGroup-Exists-p (name)
  2829.   (if
  2830.     (member
  2831.       (strcase name)
  2832.       (mapcar 'strcase (MJ:MenuGroups-ListAll))
  2833.     )
  2834.      (vl-position name (MJ:MenuGroups-ListAll))
  2835.   )
  2836. )
  2837. ;;78.4 [功能] 工具条Vla集合
  2838. (defun MJ:Toolbars (mgroup)
  2839.   (if (MJ:MenuGroup-Exists-p mgroup)
  2840.     (vla-get-toolbars
  2841.       (vla-item
  2842. (MJ:MenuGroups)
  2843. (vl-position
  2844.    (strcase mgroup)
  2845.    (mapcar 'strcase (MJ:MenuGroups-ListAll))
  2846. )
  2847.       )
  2848.     )
  2849.   )
  2850. )
  2851. ;;78.5 [功能] 工具条列表
  2852. ;;(MJ:ToolbarsList "CXinZhi")返回("附加图层工具" "附加文字工具" "附加标准工具")
  2853. (defun MJ:ToolbarsList (mgroup / tb out)
  2854.   (if (setq tb (MJ:Toolbars mgroup))
  2855.     (vlax-for each tb
  2856.       (setq out (cons (vla-get-name each) out))
  2857.     )
  2858.   )
  2859.   (reverse out)
  2860. )
  2861. ;;78.6 [功能] 工具条列表
  2862. ;; Arguments: 菜单名称
  2863. ;; 示例:   (ListToolbars "acad")(ListToolbars "CXinZhi")
  2864. (defun MJ:ListToolbars (groupName / mGroups mGroup lst)
  2865.   (if (not
  2866. (vl-catch-all-error-p
  2867.    (setq
  2868.      mGroup (vl-catch-all-apply
  2869.        'vla-item
  2870.        (list (vla-get-menugroups *ACAD*)
  2871.       groupName
  2872.        )
  2873.      )
  2874.    )
  2875. )
  2876.       )
  2877.     (vlax-for tBar (vla-get-toolbars mGroup)
  2878.       (setq lst (cons (vla-get-name tBar) lst))
  2879.     )
  2880.   )
  2881. )
  2882. ;;78.7 [功能] 工具条是否存在
  2883. ;;(MJ:Toolbar-Exists-p "CXinZhi" "附加图层工具");返回0
  2884. (defun MJ:Toolbar-Exists-p (mgroup tbname)
  2885.   (if
  2886.     (and
  2887.       (MJ:MenuGroup-Exists-p mgroup)
  2888.       (member
  2889. (strcase tbname)
  2890. (mapcar 'strcase (MJ:Toolbars-ListAll mgroup))
  2891.       )
  2892.     )
  2893.      (vl-position tbname (MJ:Toolbars-ListAll mgroup))
  2894.   )
  2895. )
  2896. ;;78.8 [功能] 指定工具条(Vla)
  2897. (defun MJ:Toolbar (mgroup tbname / loc)
  2898.   (if (setq loc (MJ:Toolbar-Exists-p mgroup tbname))
  2899.     (vla-item (MJ:Toolbars mgroup) loc)
  2900.   )
  2901. )
  2902. ;;78.9 [功能] 显示指定工具条
  2903. ;;(MJ:Toolbar-Show "ACAD" "UCS")将显示UCS工具条
  2904. ;;(MJ:Toolbar-Show "CXinZhi" "附加图层工具")
  2905. (defun MJ:Toolbar-Show (mgroup tbname / tb)
  2906.   (if (setq tb (MJ:Toolbar mgroup tbname))
  2907.     (if (= (vla-get-visible tb) :vlax-false)
  2908.       (progn
  2909. (vla-put-visible tb :vlax-true)
  2910. T
  2911.       )
  2912.     )
  2913.   )
  2914. )
  2915. ;;78.10 [功能] 隐藏工具条
  2916. (defun MJ:Toolbar-Hide (mgroup tbname / tb)
  2917.   (if (setq tb (MJ:Toolbar mgroup tbname))
  2918.     (if (= (vla-get-visible tb) :vlax-true)
  2919.       (progn
  2920. (vla-put-visible tb :vlax-false)
  2921. T
  2922.       )
  2923.     )
  2924.   )
  2925. )
  2926. ;;78.11 [功能] 工具条放置位置
  2927. ;; NOTES: Allowable <dock> values are 0(top), 1(bottom), 2(left),            ;;
  2928. ;;        and 3(right). Returns 1 if successful, -1 if toolbar is not        ;;
  2929. ;;        visible, -2 if parameter is invalid, or 0 if toolbar not found.    ;;
  2930. (defun MJ:Toolbar-Dock (mgroup tbname dock / tb)
  2931.   (if (setq tb (MJ:Toolbar mgroup tbname))
  2932.     (if (= (vla-get-visible tb) :vlax-true)
  2933.       (if (member dock '(0 1 2 3))
  2934. (progn
  2935.    (vlax-invoke-method tb 'Dock dock)
  2936.    1
  2937. )
  2938. -2
  2939. ;; invalid dockstatus parameter
  2940.       )
  2941.       -1
  2942.       ;; toolbar not visible
  2943.     )
  2944.     0
  2945.     ;; toolbar not found
  2946.   )
  2947. )
  2948. ;;78.12 [功能] Float a given toolbar at specified position(top and left)
  2949. ;;   and display with specified number of rows. Returns 1 if successful,
  2950. ;;   -1 if toolbar is not visible, 0 if toolbar is not found.
  2951. (defun MJ:Toolbar-Folat (mgroup tbname top left rows)
  2952.   (if (setq tb (MJ:Toolbar mgroup tbname))
  2953.     (if (= (vla-get-visible tb) :vlax-true)
  2954.       (progn
  2955. (vlax-invoke-method tb 'Float top left rows)
  2956. 1
  2957.       )
  2958.       -1
  2959.       ;; toolbar not visible
  2960.     )
  2961.     0
  2962.     ;; toolbar not found
  2963.   )
  2964. )
  2965. ;;78.13 [功能] 改变工具条按钮位图
  2966. ;; 示例:   (MJ:ChangeBitmap "acad" "dimension" "linear dimension" "test.bmp")
  2967. ;; Notes:     1. If the bitmap is not in the AutoCAD search path, you must specify      ;;
  2968. ;;               the full path to file        ;;
  2969. (defun MJ:ChangeBitmap (mnuGroup tbrName btnName bitmap)
  2970.   (vl-load-com)
  2971.   (vla-setbitmaps
  2972.     (vla-item
  2973.       (vla-item
  2974. (vla-get-toolbars
  2975.    (vla-item (vla-get-menugroups *ACAD*)
  2976.       mnuGroup
  2977.    )
  2978. )
  2979. tbrName
  2980.       )
  2981.       btnName
  2982.     )
  2983.     bitmap
  2984.     bitmap
  2985.   )
  2986.   (princ)
  2987. )
  2988. ;;79 [功能] 2D点转成vla 2D
  2989. (defun MJ:2DPoint (pt)
  2990.   (vl-load-com)
  2991.   (vlax-make-variant
  2992.     (vlax-safearray-fill
  2993.       (vlax-make-safearray vlax-vbdouble '(0 . 1))
  2994.       (list (car pt) (cadr pt))
  2995.     )
  2996.   )
  2997. )
  2998. ;;80.1 [功能] 激活最左边一个布局
  2999. ;;下面程序使用vla-activate有问题,看起来没有错误
  3000. ;;模型和布局之间自由切换(setvar "CTAB" "layout2")
  3001. (defun MJ:ActivateLastLayout (/ CNT I)  
  3002.   (vlax-for layout *LOUTS*
  3003.     (if (= (vla-get-taborder layout) 1);取得布局的tab顺序,图纸空间的标签(tab)顺序必须是1或大于1
  3004.       (vla-put-ActiveLayout *DOC* layout) ; (vla-activate layout)运行有问题      
  3005.     )
  3006.   )
  3007. )
  3008. ;;80.2 [功能] 激活第二个图形[Ctrl+Tab] 见10
  3009. (defun MJ:ActivateDrawing ()  
  3010.   (vla-activate (vla-item *docs* 1))
  3011. )

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

点评

黄大侠的附件无法下载了,我在453楼重新提供了附件下载,不知道黄大侠现在还有没有再新增加的?  发表于 2016-11-16 19:15
Kye
第一个附件无法下载,245楼黄老师提供新的下载地址http://bbs.xdcad.net/thread-668878-1-1.html 另外82楼 crazylsp大侠 将黄老师的常用函数做成word文件,建议crazylsp大侠设置成免币下载 谢谢黄老师!!!  发表于 2014-5-6 12:17
呵呵,虽然版主不收币了,那我就送两币了。不多,聊表心意吧  发表于 2013-6-21 05:26
反复更新反复收币?还是付过币的不收费?你都成爆发户哈。公平的说,你应把最初之后的更新别发一个包让人免费下载才言行一致辞。  发表于 2012-9-28 15:39
必须得顶,管他偷的抄的,能用的就是自个的;  发表于 2012-9-21 09:08
继续整理啊,这开了个好头了啊  发表于 2012-9-20 17:32
要得要得,我来下载瞧瞧  发表于 2012-9-20 17:14

评分

参与人数 25明经币 +24 金钱 +221 收起 理由
414249149 + 1 很给力!
tigcat + 10 很给力!
moshouhot + 1 + 50 很给力!
YuHB + 1
BaoWSE + 1 很给力!
白丝折纸 + 1 + 10 很给力!
wwwbxd + 1 赞一个!
maoyang + 1 很给力!
biya + 5 可惜不能下载
bzhjl + 1 赞一个!

查看全部评分

"觉得好,就打赏"
还没有人打赏,支持一下

本帖被以下淘专辑推荐:

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

点评

楼主无私!!!!!!  发表于 2024-8-7 21:43
讲得好  发表于 2013-8-7 09:45
哈哈  发表于 2012-9-25 10:46
回复 支持 2 反对 0

使用道具 举报

发表于 2016-7-22 01:57:25 来自手机 | 显示全部楼层
自贡黄明儒 发表于 2012-11-22 09:55
;;28.2 [功能] 删除未使用的图层,比purge彻底
(defun MJ:LayerDelete ()
  (vl-Load-Com)

加载2是什么意思,加载哪一个呢?
回复 支持 0 反对 1

使用道具 举报

发表于 2012-9-20 16:33:21 | 显示全部楼层
既然是收集,建议还是免币下载吧

点评

老黄的币比版主还多哈,你知道是什么原因。  发表于 2012-9-28 15:43
其实我并不确币......  发表于 2012-9-20 21:03
发表于 2012-9-20 16:39:22 | 显示全部楼层
板凳啊!
发表于 2012-9-20 16:44:15 | 显示全部楼层
感谢楼主分享,学习了!
发表于 2012-9-20 16:54:33 | 显示全部楼层
感谢楼主分享..........
发表于 2012-9-20 17:15:25 | 显示全部楼层
支持一下,收集辛苦了
发表于 2012-9-20 18:07:31 | 显示全部楼层
加油啊, 继续............
发表于 2012-9-20 18:07:38 来自手机 | 显示全部楼层
支持支持!
发表于 2012-9-20 18:36:01 | 显示全部楼层
非常之感谢 哥 你要什么你说
发表于 2012-9-20 18:47:14 | 显示全部楼层
才100多个就算多了……
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-22 14:16 , Processed in 0.297426 second(s), 30 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表