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