常用函数 收集：自贡黄明儒

1 [功能] 检查加载vlisp扩展

;;1 [功能] 检查加载vlisp扩展
(vl-Load-COM)

2 常数(lisp编辑器在输出局部变量时,带*的会排在前面.Caoyin这样写很有道理)

;;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对象

;;3 [功能] 返回活动空间vla对象
(defun MJ:ActiveSpace() 
  (if (= 1 (vlax-get-Property DOC* 'ActiveSpace));模型1,布局0
    *MS*
    *PS*
  )
)

4 [功能] 空间

4.1 [功能] 返回当前活动空间名称(“Model” or “Paper”)

;;4.1 [功能] 返回当前活动空间名称("Model" or "Paper")
(defun MJ:ActiveSpace-Name ()
  (if (= 1 (vla-get-ActiveSpace *DOC*))
    "Model"
    "Paper"
  )
)

4.2 [功能] 返回空间名称,如”Model”或者”Layout1”…

;;4.2 [功能] 返回空间名称,如"Model"或者"Layout1"...
(defun MJ:ActiveSpace1 ()
  (vla-get-Name (vla-get-ActiveLayout *DOC*))
)

5 [功能] 返回Preferences vla对象

;;5 [功能] 返回Preferences vla对象
(defun MJ:AcadPrefs ()
  (vlax-Get-Property *ACAD* 'Preferences)
)

6 [功能] 返回指定引用的属性

;;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 [功能] 更改引用设置

;;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对象的属性

;;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 [功能] 对象名称

;;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 [功能] 文件

10.1 [功能] 打开文件名列表

;;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 [功能] (打开文件 未打开文件)列表

;;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 [功能] 查询对象属性和方法

;;11 [功能] 查询对象属性和方法
(defun C:HHDump (/ ent)
  (while (setq ent (entsel))
    (vlax-Dump-Object
      (vlax-Ename->Vla-Object (car ent))
    )
  )
  (princ)
)

12 [功能] 设置 Qleader 命令“引线设置”对话框的相关参数

;;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 无痕

;;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 [功能] 集合数量

14.1 [功能] 返回指定集合的数量

;;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 [功能] 返回文档指定对象的属性

;;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 [功能] 图层集合

;;15.1 [功能] 图层集合
(defun MJ:GetLayers () (vlax-Get-Property *DOC* 'Layers))

15.2 [功能] 线型集合

;;15.2 [功能] 线型集合
(defun MJ:GetLtypes () (vlax-Get-Property *DOC* 'Linetypes))

15.4 [功能] 尺寸样式集合

;;15.4 [功能] 尺寸样式集合
(defun MJ:GetDimStyles () (vlax-Get-Property *DOC* 'DimStyles))

15.5 [功能] 布局集合

;;15.5 [功能] 布局集合
(defun MJ:GetLayouts () (vlax-Get-Property *DOC* 'Layouts))

15.6 [功能] 词典集合

;;15.6 [功能] 词典集合
(defun MJ:GetDictionaries () (vlax-Get-Property *DOC* 'Dictionaries))

15.7 [功能] 块集合(不是我们平时绘图时所说的块)

;;15.7 [功能] 块集合(不是我们平时绘图时所说的块)
(defun MJ:GetBlocks () (vlax-Get-Property *DOC* 'Blocks))

15.8 [功能] 打印配置集合

;;15.8 [功能] 打印配置集合
(defun MJ:GetPlotConfigs ()(vlax-Get-Property *DOC* 'PlotConfigurations))

15.9 [功能] 视图集合

;;15.9 [功能] 视图集合
(defun MJ:GetViews () (vlax-Get-Property *DOC* 'Views))

15.10 [功能] 视口集合

;;15.10 [功能] 视口集合
(defun MJ:GetViewports () (vlax-Get-Property *DOC* 'Viewports))

15.11 [功能] 组集合

;;15.11 [功能] 组集合
(defun MJ:GetGroups () (vlax-Get-Property *DOC* 'Groups))

15.12 [功能] 注册程序集合

;;15.12 [功能] 注册程序集合
(defun MJ:GetRegApps () (vlax-Get-Property *DOC* 'RegisteredApplications))

16 [功能] 返回集合成员名称列表

;;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)

;;16.1 [功能] 返回线型集合成员名称列表(常量*LTS*)
(defun MJ:ListLtypes ()
  (MJ:ListCollectionMemberNames (vlax-Get-Property *DOC* 'Linetypes))
)

16.2 [功能] 图层列表(常量LAYS)

;;16.2 [功能] 图层列表(常量*LAYS*)
;;示例("0" "中心线" "文字" "DIM")
(defun MJ:ListLayers ()
  (MJ:ListCollectionMemberNames (vlax-Get-Property *DOC* 'Layers))
)

16.3 [功能] 返回文字样式集合成员名称列表(常量STS)

;;16.3 [功能] 返回文字样式集合成员名称列表(常量*STS*)
(defun MJ:ListTextStyles ()
  (MJ:ListCollectionMemberNames (vlax-Get-Property *DOC* 'TextStyles))
)

16.4 [功能] 返回尺寸样式集合成员名称列表

;;16.4 [功能] 返回尺寸样式集合成员名称列表
(defun MJ:ListDimStyles ()
  (MJ:ListCollectionMemberNames *DIMS*)
)

16.5 [功能] 返回布局集合成员名称列表

;;16.5 [功能] 返回布局集合成员名称列表
(defun MJ:ListLayouts    ()
  (MJ:ListCollectionMemberNames *LOUTS*)
)

16.6 [功能] 返回词典集合成员名称列表

;;16.6 [功能] 返回词典集合成员名称列表
(defun MJ:ListDictionaries ()
  (MJ:ListCollectionMemberNames *DICS*)
)

16.7 [功能] 返回块集合成员名称列表

;;16.7 [功能] 返回块集合成员名称列表
(defun MJ:ListBlocks ()
  (MJ:ListCollectionMemberNames *BLKS*)
)

16.8 [功能] 返回打印配置集合成员名称列表

;;16.8 [功能] 返回打印配置集合成员名称列表
(defun MJ:ListPlotConfigs ()
  (MJ:ListCollectionMemberNames (MJ:GetPlotConfigs))
)

16.9 [功能] 返回视图集合成员名称列表

;;16.9 [功能] 返回视图集合成员名称列表
(defun MJ:ListViews ()
  (MJ:ListCollectionMemberNames (MJ:GetViews))
)

16.10 [功能] 返回视口集合成员名称列表(同常量VPS)

;;16.10 [功能] 返回视口集合成员名称列表(同常量*VPS*)
(defun MJ:ListViewPorts ()
  (MJ:ListCollectionMemberNames (MJ:GetViewports))
)

16.11 [功能] 返回组集合成员名称列表

;;16.11 [功能] 返回组集合成员名称列表
(defun MJ:ListGroups ()
  (MJ:ListCollectionMemberNames (MJ:GetGroups))
)

16.12 [功能] 返回注册程序集合成员名称列表

;;16.12 [功能] 返回注册程序集合成员名称列表
(defun MJ:ListRegApps    ()
  (MJ:ListCollectionMemberNames (MJ:GetRegApps))
)

17 [功能] 点表排序(根据x Y 或者Z坐标排序)

;;17 [功能] 点表排序(根据x Y 或者Z坐标排序)
;; 示例: (MJ:SortPoints MJ:Points "Y") 按Y排序
(defun MJ:SortPoints (points-list xyz)
  (setq xyz (strcase xyz))
  (cond
    ((= xyz "Z")
     (vl-sort points-list
          (function (lambda (p1 p2) (< (caddr p1) (caddr p2))))
     )
     ;|; 3-point lists required!
     (if
       (apply '= (mapcar '(lambda (lst) (length lst)) points-list));如果各点长度同
    (vl-sort points-list (function (lambda (p1 p2) (< (caddr p1) (caddr p2)))))
    (princ "\nCannot sort on Z-coordinates with 2D points!")
     )|;
    )
    ((= xyz "X")
     (vl-sort
       points-list
       (function (lambda (p1 p2) (< (car p1) (car p2))))
     )
    )                    
    ((= xyz "Y")
     (vl-sort
       points-list
       (function (lambda (p1 p2) (< (cadr p1) (cadr p2))))
     )
    )
  )
)

18 [功能] 集合->列表

;;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 [功能] 线型数量

;;19 [功能] 线型数量
(defun MJ:CountLtypes    ()
  (MJ:CollectionCount (vlax-Get-Property *DOC* 'Linetypes))
)

20 [功能] 对集合对象的每个成员执行指定函数的操作

;;20 [功能] 对集合对象的每个成员执行指定函数的操作
;; 示例: (MJ:MapCollection all-arcs 'MJ:DeleteObject)
(defun MJ:MapCollection (Collection qFunction)
  (vlax-map-collection Collection qFunction)
)

20.1 [功能] 显示集合对象每个成员的方法和属性.既然是集合,方法是相同的

;;20.1 [功能] 显示集合对象每个成员的方法和属性.既然是集合,方法是相同的
;; 示例: (MJ:DumpCollection (MJ:GetLayers))
(defun MJ:DumpCollection (Collection)
  (MJ:MapCollection Collection 'vlax-dump-object)
)

20.2 [功能] 删除对象

;;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对象

21.1 [功能] ename->vla对象

;;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

;;21.2 [功能] vla对象->ename
(defun MJ:MakeEname (object)
  (if (equal (type object) 'vla-object)
    (*Obj2En* object)
    object
  )
)

22 [功能] 返回对象名称(见9)

;;22 [功能] 返回对象名称(见9)
;; 示例: (= "AcDbArc" (MJ:ObjectType MJ:object))
(defun MJ:ObjectType (obj)
  (vlax-get-property obj 'ObjectName)
)

23 编组

23.1 编组开始(command “_.undo” “be”)

;;23.1 编组开始(command "_.undo" "be")
(defun MJ:UndoBegin ()
  (vlax-invoke-method *DOC* 'StartUndoMark)
)

23.2 编组结束(command “_.undo” “END”)

;;23.2 编组结束(command "_.undo" "END")
(defun MJ:UndoEnd ()
  (vlax-invoke-method *DOC* 'EndUndoMark)
)

24 [功能] 用一个对象的属性等修改另一个对象的属性

;;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 [功能] 用一个对象的’(图层 线型…)修改另一个对象的图层 线型…等

;;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 [功能] 配置文件

25.1 [功能] 配置文件集合

;;25.1 [功能] 配置文件集合
(defun MJ:Profiles ()
  (vla-get-Profiles (MJ:AcadPrefs))
)

25.2 [功能] 设置配置文件

;;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 [功能] 重新装载配置文件

;;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 [功能] 重启默认配置文件

;;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 [功能] 输出配置文件

;;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 [功能] 输出配置文件

;;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 [功能] 输入配置文件

;;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 [功能] 复制配置文件

;;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 [功能] 重命名配置文件

;;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 [功能] 删除配置文件

;;25.10 [功能] 删除配置文件
;; 示例: (MJ:ProfileDelete "MJ:Profile")
(defun MJ:ProfileDelete (pName)
  (vlax-invoke-method
    (vlax-get-property (MJ:AcadPrefs) "Profiles")
    'DeleteProfile
    pName
  )
)

25.11 [功能] 配置文件是否存在

;;25.11 [功能] 配置文件是否存在
;; 示例: (if (MJ:ProfileExists-p "<<Unnamed Profile>>") ...)
(defun MJ:ProfileExists-p (pName)
  (member (strcase pName) (mapcar 'strcase (MJ:ProfileList)))
)

25.12 [功能] 配置文件列表

;;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-161

;;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-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))
)
;;81 [功能] VLA选择集过滤条件Returns a list containing a pair of variants for use as
;;            ActiveX selection set filters
;; 示例:   (MJ:BuildFilter '((0 . "LWPOLYLINE") (8 . "WALLS")))
(defun MJ:BuildFilter (filter)
  (vl-load-com)
  (mapcar '(lambda (lst typ)
         (vlax-make-variant
           (vlax-safearray-fill
         (vlax-make-safearray
           typ
           (cons 0
             (1- (length lst))
           )
         )
         lst
           )
         )
       )
      (list (mapcar 'car filter) (mapcar 'cdr filter))
      (list vlax-vbInteger vlax-vbVariant)
  )
)
;;81 [功能] 类型库智能化加载
;;用法: (vlax-load-type-libeary ProgID[STRING] UniquePrefix[STR] )
;;        (vlax-load-type-libeary ProgID[STRING] PrefixList[STR] )
;;  参数1: 与vlax-get-create-object 函数相同的ProgID 字符串
;;  参数2: 前缀，可以是字符串或表
;;         表的顺序 (:methods-prefix :properties-prefix :constants-prefix)
;;说明: 此函数读取 Windows REGISTRY 并且侦测合适的 DLL/OCX/EXE 类型库并自动加载
;;返回值: T 或者 nil
(Defun vlax-load-type-library
       (File Prefix / FileX Host N KeyX Val OSVar rtn)
  (setq    Host "HKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\CLSID"
    N    -1
    KeyX (vl-registry-descendents Host)
  )
  (while (< (setq N (1+ N))
        (length KeyX)
     )
    (if    (and (setq Val (vl-registry-read
             (strcat Host "\\" (nth N KeyX) "\\ProgID")
               )
         )
         (vl-string-search (strcase File) (strcase Val))
    )
      (setq FileX (vl-registry-read
            (strcat Host "\\" (nth N KeyX) "\\InProcServer32")
          )
        N      (length KeyX)
      )
    )
  )
  (if (= (type Prefix) 'STR)
    (setq Prefix (list Prefix Prefix (strcat ":" Prefix)))
  )
  (if (= (type FileX) 'LIST)
    (setq FileX (cdr FileX))
  )
  (if (= (type FileX) 'STR)
    (progn
      (setq FileX (strcase FileX))
      (foreach OSVar (list "SYSTEMROOT"         "WINDIR"
               "WINBOOTDIR"         "SYSTEMDRIVE"
               "USERNAME"         "COMPUTERNAME"
               "HOMEDRIVE"         "HOMEPATH"
               "PROGRAMFILES"
              )
    (if (vl-string-search (strcat "%" OSVar "%") FileX)
      (setq    FileX (vl-string-subst
            (strcase (getenv OSVar))
            (strcat "%" OSVar "%")
            FileX
              )
      )
    )
      )
      (if (setq rtn (findfile FileX))
    (setq rtn
           (vlax-import-type-library
         :tlb-filename
         FileX
         :methods-prefix
         (nth 0 Prefix)
         :properties-prefix
         (nth 1 Prefix)
         :constants-prefix
         (nth 2 Prefix)
           )
    )
      )
    )
  )
  rtn
)
;;82 [功能] 转换路径中字符 "/" 为 "\\" 并返回大写值
;;用法: (vldos-formatpath PathStringToFormat[STRING] )
;;参数1: 路径字符串
;;返回值:转换后的字符串 或者  None
(Defun vldos-formatpath    (string)
  (while (vl-string-search "/" string)
    (setq string (vl-string-subst "\\" "/" string))
  )
  (while (vl-string-search "\\\\" string)
    (setq string (vl-string-subst "\\" "\\\\" string))
  )
  (strcase string)
)
;;83 [功能] 通过IE 显示一个 HTML 字符串
;;用法: (vldos-text->ie ContentString[STRING] )
;;  参数1: 要显示的字符串或字符串表
;;说明: 传送数据至新打开的IE窗口
;;返回值: 包括字符串的新打开的IE窗口 OR NIL
(Defun vldos-text->ie (TXT / list->string ie ln doc)
  (if (= (type TXT) 'STR)
    (setq TXT (list TXT))
  )
  (if (setq ie (vlax-create-object "InternetExplorer.Application"))
    (progn
      (vlax-put-property ie 'menubar 0)
      (vlax-put-property ie 'toolbar 0)
      (vla-put-visible ie t)
      (vlax-invoke-method ie 'navigate "about :blank")
      (setq doc (vlax-get-property ie 'document))
      (foreach ln TXT
    (vlax-invoke-method doc 'writeln ln "")
      )
      (vlax-invoke-method doc 'close)
      (vlax-release-object doc)
      (vlax-release-object ie)
    )
  )
)
;;84.1 [功能] 显示时间/日期对话框
;;用法: (vldos-time)
;;返回值: 显示时间/日期对话框 OR NIL
(Defun vldos-time (/ sys)
  (if (setq sys (vlax-create-object "Shell.Application"))
    (progn
      (vlax-invoke-method sys 'settime)
      (vlax-release-object sys)
    )
  )
)
;;84.2 [功能] Returns the logical drive letter to which a network share is mapped
;; Arguments: A UNC path
;; 示例:   (MJ:MappedShare "\\\\MJ:Server\\MJ:Share")    
;; Notes:     1. Be sure to substitute two backslashes for every one in the UNC path 
;;            2. This routine requires the use SCRRUN.DLL. Visite the
;;               Microsoft scripting web site if you do not have it. 
(defun MJ:MappedShare (share / drives drive letter)
  (vlax-for drive (setq drives (vlax-get-property *FSO* 'Drives))
    (if    (= (strcase (vlax-get-property drive 'ShareName))
       (strcase share)
    )
      (setq letter (vlax-get-property drive 'DriveLetter))
    )
  )
  (vlax-release-object drives)
  letter
)
;;84.3 [功能] 返回驱动器类型
;; 示例:   (mapcar 'MJ:DriveType (MJ:ListDrives))
;; Notes:     1. This routine requires the use SCRRUN.DLL.
;;               Visit the Microsoft scripting web site if you do not have it.
;;方法:  BuildPath (2),CopyFile (3),CopyFolder (3),CreateFolder (1),CreateTextFile (3),DeleteFile (2),DeleteFolder (2)
;;DriveExists (1),FileExists (1),FolderExists (1),GetAbsolutePathName (1),GetBaseName (1),GetDrive (1),GetDriveName (1)
;;GetExtensionName (1),GetFile (1),GetFileName (1),GetFileVersion (1),GetFolder (1),GetParentFolderName (1)
;;GetSpecialFolder (1),GetStandardStream (2),GetTempName (),MoveFile (2),MoveFolder (2),penTextFile (4)
(defun MJ:DriveType (drv / drives drive typ)
  (if (vlax-invoke-method *FSO* 'DriveExists drv)
    (progn
      (setq drives (vlax-get-property *FSO* 'Drives)
        drive  (vlax-get-property drives 'Item drv)
        typ       (vlax-get-property drive 'DriveType)
      )
      (vlax-release-object drive)
      (vlax-release-object drives)
      (nth typ
       '("UNKNOWN" "REMOVABLE" "FIXED" "REMODTE" "CDROM" "RAMDISK")
      )
    )
  )
)
;;84.4 [功能] 返回驱动器列表
(defun MJ:ListDrives (/ drive drives lst)
  (vlax-for drive (setq drives (vlax-get-property*FSO* 'Drives))
    (setq lst (cons (vlax-get-property drive 'DriveLetter) lst))
  )
  (vlax-release-object drives)
  (reverse lst)
)
;;84.5 [功能] 修改本地磁盘的卷标
;;用法: (vldos-label DriveLetter[STRING] NewVolumnName[STRING] )
;;  参数1: 盘符 例如: "C" 或 "C:"
;;  参数2: 新卷标, 如果长度超过11个字符, 自动裁掉
;;        <<< 本函数不检查字符串是否符合命名规则 >>>
;;返回值: 新卷标 or  NIL
(Defun vldos-Label (DRV NEW / Fil DDD ERR)
  (if (> (strlen NEW) 11)
    (setq NEW (substr New 1 11))
  )
  (if (setq Fil (vlax-get-or-create-object "Scripting.FileSystemObject"))
    (progn
      (setq DDD (vlax-invoke-method Fil 'GetDrive DRV))
      (vlax-put-property DDD "VolumeName" NEW)
      (if (not (eq (setq NEW (strcase NEW))
           (strcase (vlax-get-property DDD "VolumeName"))
           )
      )
    (setq NEW nil)
      )
      (vlax-release-object DDD)
      (vlax-release-object FIL)
    )
    (setq New nil)
  )
  NEW
)
;;84.6 [功能] 执行 DOS DELTREE 命令
;;用法: (vldos-deltree DirectoryToDelete[STRING] )
;;  参数1: 要被删除的目录名称. 此函数不显示确认过程，删除文件夹和所有的子文件夹
;;  如果参数是根目录，江删除所有的子目录.
;;返回值:  T or NIL
(Defun vldos-Deltree (Folder / sf subf FIL Rtn)
  (cond    ((vl-file-directory-p Folder)
     (if (null (setq Fil
              (vlax-get-or-create-object "Scripting.FileSystemObject")
           )
         )
       (setq Rtn nil)
       (progn
         (cond
           ((<= (strlen Folder) 3)
        (if (= (strlen folder) 2)
          (setq folder (strcat folder "\\"))
        )
        (setq subf (vl-directory-files Folder nil -1)
              subf (vl-remove "." subf)
              subf (vl-remove ".." subf)
              subf (vl-remove "Recycled" subf)
        )
        (foreach sf subf
          (vlax-invoke-method
            Fil
            'DeleteFolder
            (strcat folder sf)
            T
          )
        )
           )
           (t (vlax-invoke-method Fil 'DeleteFolder Folder T))
         )
         (vlax-release-object FIL)
         (setq Rtn (not (vl-file-directory-p Folder)))
       )
     )
    )
    ((findfile Folder)
     (vl-file-delete folder)
     (setq Rtn (not (findfile Folder)))
    )
  )
  Rtn
)
;;84.7 [功能] 创建目录
;;用法: (vldos-mkdir DirectoryToCreate[STRING] )
;;参数1: 目录的全路径名. 此函数会自动创建参数中所有不存在的目录.
;;返回值: 创建目录的全路径名 or  NIL
(Defun vldos-MkDir (Folder / FolderX Fil FFF Pos DIR DRV)
  (if (null
    (setq
      Fil (vlax-get-or-create-object "Scripting.FileSystemObject")
    )
      )
    (setq Folder nil)
    (progn
      (while (vl-string-search "/" Folder)
    (setq Folder (vl-string-subst "\\" "/" Folder))
      )
      (if (wcmatch Folder "*\\")
    (setq Folder (substr Folder 1 (1- (strlen Folder))))
      )
      (setq FolderX Folder)
      (while (setq Pos (vl-string-search "\\" Folder))
    (setq FFF    (cons (substr Folder 1 Pos) FFF)
          Folder (substr Folder (+ Pos 2))
    )
      )
      (setq FFF    (reverse (cons Folder FFF))
        DRV    (car FFF)
        FFF    (cdr FFF)
      )
      (foreach DIR FFF
    (if
      (null    (vl-file-directory-p (setq DRV (strcat DRV "\\" DIR)))
      )
       (vlax-invoke-method
         Fil
         'createfolder
         DRV
       )
    )
      )
      (vlax-release-object Fil)
      (if (setq Folder (vl-file-directory-p FolderX))
    (setq Folder (vldos-formatpath FolderX))
      )
    )
  )
  Folder
)
;;84.8 [功能] 复制文件或目录
;;用法: (vldos-copy SourceFile/Directory[STRING] TargetFile/Directory[STRING] )
;;  参数1: 源文件或目录
;;  参数2: 目标目录. 如果包含 "*\\" or "*/", 此函数将在此路径下创建相同的子目录.
;; 返回值: 复制的文件或目录字符串 or NIL
(Defun vldos-copy (from to / sys folder)
  (setq    from (vldos-formatpath from)
    to   (vldos-formatpath to)
  )
  (if (null (vl-file-directory-p to))
    (setq to (vldos-mkdir to))
  )
  (if (setq sys (vlax-get-or-create-object "Shell.Application"))
    (progn
      (if (setq folder (vlax-invoke-method sys 'namespace to))
    (progn
      (princ
        (strcat "\n Copying file(s) from \042"
            FROM           "\042 to \042"
            to               "\042..."
           )
      )
      (vlax-invoke-method folder 'copyhere from (+ 4 16))
      (vlax-release-object folder)
      (princ "...Done!")
    )
      )
      (vlax-release-object sys)
    )
  )
  (princ)
)
;;84.9 [功能] 复制目录下所有文件和目录
;;示例 (vldos-copy2 (getvar "dwgprefix") "C:\\mtool\\SUPPORT")
(Defun vldos-copy2 (From to / rtn)
  (cond
    ((vl-file-directory-p From)
     (if (< (strlen to) 3)
       (setq to (strcat to "\\"))
       (if (not (vl-file-directory-p to))
     (vldos-mkdir to)
       )
     )
     (if (setq
       Rtn (vlax-get-or-create-object "Scripting.FileSystemObject")
     )
       (progn
     (vlax-invoke-method Rtn 'CopyFolder From to T)
     (vlax-release-object Rtn)
     (if (vl-file-directory-p to)
       (setq Rtn (vldos-formatpath to))
     )
       )
     )
    )
    ((findfile From)
     (vl-file-copy From to)
     (if (setq rtn (findfile to))
       (setq rtn (vldos-formatpath rtn))
     )
    )
  )
  rtn
)
;;84.10 [功能] 移动文件或目录
;;用法: (vldos-move SourceFile/Directory[STRING] TargetFile/Directory[STRING] )
;;  参数1: 源文件或目录.
;;  参数2: 目标目录. 如果包含 "*\\" or "*/", 此函数将在此路径下创建相同的子目录.
;;返回值: 移动后的文件或目录字符串 or  NIL
(Defun vldos-move (from to / sys folder)
  (if (setq sys (vlax-get-or-create-object "Shell.Application"))
    (progn
      (setq from   (vldos-formatpath from)
        to       (vldos-formatpath to)
        folder (vlax-invoke-method sys 'namespace to)
      )
      (if folder
    (progn
      (princ
        (strcat "\n Moving file(s) from \042"
            FROM           "\042 to \042"
            to               "\042..."
           )
      )
      (vlax-invoke-method folder 'movehere from (+ 4 16))
      (vlax-release-object folder)
      (princ "...Done!")
    )
      )
      (vlax-release-object sys)
    )
  )
  (princ)
)
;;84.11 [功能] 重命名文件或目录
;;用法: (vldos-rename SourceFile/Directory[STRING] NewName[STRING] )
;;  参数1: 源文件或目录.
;;  参数2: 新名称.
;;返回值: 重命名后的文件或目录 or NIL
(Defun vldos-rename (From to / Fil folder new parent rtn)
  (cond
    ((vl-file-directory-p From)
     (setq parent (vl-filename-directory From)
       new      (strcat parent to)
     )
     (if (and (setq
        Fil
         (vlax-get-or-create-object "Scripting.FileSystemObject")
          )
          (> (strlen From) 3)
          ;; Can not rename root folder
          (null (vl-file-directory-p new))
          ;; not an existing folder name
     )
       (progn
     (setq folder (vlax-invoke-method Fil 'GetFolder From))
     (vlax-put-property folder "Name" To)
     (vlax-release-object folder)
     (vlax-release-object Fil)
       )
       (setq parent nil)
     )
    )
    ((findfile From)
     (setq parent (vl-filename-directory from))
     (vl-file-rename From to)
    )
  )
  (if (and parent
       (vl-file-directory-p
         (setq to (strcat parent to))
       )
      )
    (setq rtn (vldos-formatpath to))
  )
  rtn
)
;;84.12 [功能] 返回磁盘的类型
;;用法: (vldos-drivetype DriveLetter[STRING] )
;;  参数1: 盘符 例如: "C:"
;;返回值: 磁盘的类型 or NIL
(Defun vldos-drivetype (drv / Fil drives drive typ rtn)
  (setq rtn "INVALID")
  (if
    (and (setq
       Fil (vlax-get-or-create-object "Scripting.FileSystemObject")
     )
     (equal :vlax-true (vlax-invoke-method Fil 'DriveExists drv))
    )
     (progn
       (setq drives (vlax-get-property Fil 'Drives)
         drive  (vlax-get-property drives 'Item drv)
         typ    (vlax-get-property drive 'DriveType)
         rtn    (nth typ
             (list "UNKNOWN"     "REMOVABLE"
                   "FIXED"         "REMOTE"
                   "CDROM"         "RAMDISK"
                  )
            )
       )
       (vlax-release-object drive)
       (vlax-release-object drives)
       (vlax-release-object Fil)
     )
  )
  rtn
)
;;84.13 [功能] 返回当前的磁盘表
;;用法: (vldos-alldrive)
;;返回值: 返回当前的磁盘表 or NIL
(Defun vldos-alldrive (/ fil drive drives lst)
  (if (setq Fil (vlax-get-or-create-object "Scripting.FileSystemObject"))
    (progn
      (vlax-for    drive (setq drives (vlax-get-property Fil 'Drives))
    (setq lst (cons (vlax-get-property drive 'DriveLetter) lst))
      )
      (vlax-release-object drives)
      (vlax-release-object Fil)
      (setq lst (reverse lst))
    )
  )
  lst
)
;;[功能] 返回磁盘的特定信息
;;用法: (vldos-driveinfo DriveLetter[STRING] key[STRING] )
;;  参数1: 盘符 例如: "C:"
;;  参数2: 所需磁盘信息的字符串
;;返回值: 磁盘的特定信息 or NIL
;|
"TOTALSIZE"    磁盘总空间
"FREESPACE"    磁盘可用空间
"DRIVETYPE"    磁盘类型
"FILESYSTEM"   文件系统类型
"SERIALNUMBER" 磁盘序列号
"SHARENAME"    共享名称
"VOLUMENAME"   磁盘卷标
|;
(Defun vldos-driveinfo (Drv Key / pos rtn)
  (if (/= (type key) 'STR)
    (setq rtn (vldos-alldriveinfo drv))
    (if    (setq pos (vl-position
            (setq key (strcase key))
            (list "TOTALSIZE"        "FREESPACE"
              "DRIVETYPE"        "FILESYSTEM"
              "SERIALNUMBER"    "SHARENAME"
              "VOLUMENAME"
             )
          )
    )
      (setq rtn (nth pos (vldos-alldriveinfo drv)))
    )
  )
  rtn
)
;;84.14 [功能] 返回磁盘的所有信息
;;用法: (vldos-alldriveinfo DriveLetter[STRING] )
;;  参数1: 盘符 例如: "C:"
;;返回值 磁盘的所有信息 or NIL
(Defun vldos-alldriveinfo (Drv / DrvObj FilSys RetVal)
  (if (setq
    FilSys (vlax-get-or-create-object "Scripting.FileSystemObject")
      )
    (progn
      (setq RetVal
         (cond
           ((= (vlax-invoke FilSys "DriveExists" Drv) 0) 0)
           ((setq DrvObj (vlax-invoke FilSys "GetDrive" Drv))
        (cond
          ((= (vlax-get DrvObj "IsReady") 0) -1)
          ((list
             (/ (vlax-get-property DrvObj "TotalSize") 1000.0)
             (/ (vlax-get-property DrvObj "FreeSpace") 1000.0)
             (vlax-get-property DrvObj "DriveType")
             (vlax-get-property DrvObj "FileSystem")
             (vlax-get-property DrvObj "SerialNumber")
             (vlax-get-property DrvObj "ShareName")
             (vlax-get-property DrvObj "VolumeName")
           )
          )
        )
           )
         )
      )
      (if (EQUAL (TYPE DrvObj) 'vla-object)
    (vlax-release-object DrvObj)
      )
      (vlax-release-object FilSys)
    )
  )
  RetVal
)
;;84.15 [功能] 返回文件的特定信息
;;用法: (vldos-fileinfo Filename[STRING] key[STRING] )
;;  参数1: 文件全路径名
;;  参数2: 所需文件信息的字符串
;;返回值: 文件的特定信息 or NIL
;|
"DATECREATED"         创建日期
"DATELASTMODIFIED"    修改日期
"DATELASTACCESSED"    最后一次访问时间
"TYPE"                文件类型
"SIZE"                文件大小
"ATTRIBUTES"          文件属性
|;
(Defun vldos-fileinfo (Drv Key / pos rtn)
  (if (/= (type key) 'STR)
    (setq rtn (vldos-allfileinfo drv))
    (if    (setq pos (vl-position
            (setq key (strcase key))
            (list "DATECREATED"          "DATELASTMODIFIED"
              "DATELASTACCESSED"  "TYPE"
              "SIZE"          "ATTRIBUTES"
             )
          )
    )
      (setq rtn (nth pos (vldos-allfileinfo drv)))
    )
  )
  rtn
)
;;84.16 [功能] 返回磁盤的所有信息
;;用法: (vldos-alldriveinfo DriveLetter[STRING] )
;;  參數1: 盤符 例如: "C:"
;;返回值: 磁盤的所有信息 or NIL
(defun VLDOS-ALLDRIVEINFO (DRV / DRVOBJ FILSYS RETVAL)
  (if (setq
    FILSYS (vlax-get-or-create-object "Scripting.FileSystemObject")
      )
    (progn
      (setq RETVAL
         (cond
           ((= (vlax-invoke FILSYS "DriveExists" DRV) 0) 0)
           ((setq DRVOBJ (vlax-invoke FILSYS "GetDrive" DRV))
        (cond
          ((= (vlax-get DRVOBJ "IsReady") 0) -1)
          ((list
             (/ (vlax-get DRVOBJ "TotalSize") 1000.0)
             (/ (vlax-get DRVOBJ "FreeSpace") 1000.0)
             (vlax-get DRVOBJ "DriveType")
             (vlax-get DRVOBJ "FileSystem")
             (vlax-get DRVOBJ "SerialNumber")
             (vlax-get DRVOBJ "ShareName")
             (vlax-get DRVOBJ "VolumeName")
           )
          )
        )
           )
         )
      )
      (if (equal (type DRVOBJ) 'VLA-OBJECT)
    (vlax-release-object DRVOBJ)
      )
      (vlax-release-object FILSYS)
    )
  )
  RETVAL
)
;;84.17 [功能] 读文本文件到表 (快于 AutoLISP read-line函数)
;;用法: (vldos-readfile FilenameToRead[STRING] )
;;  参数1: 文本文件全路径名. (包括后缀名)
;;        只有文本文件才能返回正确结果.
;;返回值: 返回包括文件内容的表 or NIL
(Defun vldos-readfile
       (Fil / string->list FilObj FilPth FilSys OpnFil All)
  (Defun string->list (String / ID Rtn)
    (if    (null (setq ID (vl-string-search "\r\n" String)))
      (setq Rtn (list String))
      (progn
    (while ID
      (setq    Rtn    (cons (substr String 1 ID) Rtn)
        String (substr String (+ 3 ID))
        ID     (vl-string-search "\r\n" String)
      )
    )
    (setq Rtn (reverse (cons String Rtn)))
      )
    )
    Rtn
  )
  (if (AND (setq FilPth (findfile Fil))
       (setq FilSys (vlax-create-object "Scripting.FileSystemObject"))
      )
    (progn
      (setq FilObj (vlax-invoke FilSys "GetFile" FilPth)
        OpnFil (vlax-invoke FilObj "OpenAsTextStream" 1 0)
        All       (string->list (vlax-invoke OpnFil "readall"))
      )
      (vlax-invoke OpnFil "Close")
      (vlax-release-object OpnFil)
      (vlax-release-object FilObj)
      (vlax-release-object FilSys)
    )
  )
  All
)
;;84.18 [功能] 将字符串或表写入文件 (快于 AutoLISP write-line函数)
;;用法: (vldos-writefile FileNameString[STRING] ContentStringList[LIST] ModeFlag[BOOLEAN] )
;;        (vldos-writefile FileNameString[STRING] ContentString[STRING] ModeFlag[BOOLEAN] )
;;  参数1: 文本文件全路径名. (包括后缀名)
;;  参数2: 要写入文件的字符串或表
;;  参数3: 最加或覆盖标志. nil 最加, T 覆盖
;;返回值: 文本文件全路径名 or NIL
(Defun vldos-writefile
               (Fil      TXT        Mode      /
            list->string        FilObj    FilPth
            FilSys      OpnFil    Line
               )
  (Defun list->string (slist / line rtn)
    (if    (= (type slist) 'str)
      (setq rtn slist)
      (progn
    (setq rtn "")
    (foreach line slist
      (if (= rtn "")
        (setq rtn line)
        (setq rtn (strcat rtn "\r\n" line))
      )
    )
      )
    )
    rtn
  )
  (if TXT
    (progn
      (if (and Mode (findfile Fil))
    (vl-file-delete Fil)
      )
      (if (setq FilSys (vlax-create-object "Scripting.FileSystemObject"))
    (progn
      (if (null (setq FilPth (findfile Fil)))
        (setq OpnFil (vlax-invoke-method
               FilSys "CreateTextFile" Fil 0 0)
        )
        (setq FilObj (vlax-invoke FilSys "GetFile" FilPth)
          OpnFil (vlax-invoke FilObj "OpenAsTextStream" 8 0)
        )
      )
      (if OpnFil
        (progn
          ;; VBA WinScript data forReading = 1, forWriting = 2, forAppending = 8;
          ;; TristateUseDefault, TristateTrue, TristateFalse (-2, -1, 0)
          ;;TristateUseDefault (-2) Opens the file using the system default. 
          ;;TristateTrue (-1) Open the file as Unicode. 
          ;;TristateFalse (0) Open the file as ASCII. 
          (vlax-invoke OpnFil "Write" (list->string TXT))
          (vlax-invoke OpnFil "Close")
          (vlax-release-object OpnFil)
          (if (= (type FilObj) 'vla-object)
        (vlax-release-object FilObj)
          )
          (vlax-release-object FilSys)
        )
      )
    )
      )
      (if (setq Filpth (findfile Fil))
    (setq FilPth (vldos-formatpath filpth))
      )
    )
  )
  filpth
)
;;84.19 [功能] 目录浏览对话框
;;用法: (vldos-browsedir PromptString[STRING] )
;;        (vldos-writefile NIL)
;;  参数1: 提示字符串, 如果是 nil, 缺省为 "Select Folder"
;;返回值: 返回所选目录路径 OR NIL
(Defun vldos-browsedir (msg / WinShell shFolder path catchit rtn)
  (if (null MSG)
    (setq MSG "Select folder")
  )
  (if (setq winshell (vlax-create-object "Shell.Application"))
    (progn
      (setq shFolder
             (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1)
        catchit
             (vl-catch-all-apply
               '(lambda    ()
              (setq shFolder (vlax-get-property shFolder 'self))
              (setq path (vlax-get-property shFolder 'path))
            )
             )
      )
      (vlax-release-object shFolder)
      (vlax-release-object winshell)
      (if (vl-catch-all-error-p catchit)
    (setq rtn nil)
    (setq rtn (vldos-formatpath path))
      )
    )
  )
  rtn
)
;;84.20 [功能] 显示 windows 的确认对话框包括图标和可选按钮 
;;用法: (vldos-msgbox TitleString[STRING] IconType[STRING/REAL] MessageString[STRING] ButtonType[INT] )
;;  参数1: 标题字符串, 如果是 nil, 缺省为 "Message"
;;  参数2: 图标类型字符串或整数值. 如果是字符串, 只有第一个字符串有效.
;;  参数3: 消息字符串, 如果是 nil, 缺省为 "Message HERE"
;;  参数4: 按钮类型整数值.
;;返回值: 所选按钮的值 OR NIL
;|;;按钮
;;0  OK
;;1  OK and Cancel
;;2  Abort, Retry, and Ignore
;;3  Yes, No, Cancel
;;4  Yes and No
;;5  Retry and Cancel
;;图标类型
;;16 [X] Stop Mark icon
;;32 [?] Question Mark icon
;;48 [!] Exclamation Mark icon
;;64 [i] Information Mark icon
;; 返回值所代表的按钮
;;1  OK button
;;2  Cancel button
;;3  Abort button
;;4  Retry button
;;5  Ignore button
;;6  Yes button
;;7  No button
|;
(Defun vldos-msgbox (TITLE ICON MSG BTNS / IDT sys BTN)
  (if (setq sys (vlax-get-or-create-object "WScript.Shell"))
    (progn
      (if (not (equal (type TITLE) 'STR))
    (setq TITLE "Message")
      )
      (cond ((null ICON) (setq ICON 64))
        ((= (type ICON) 'STR)
         (setq ICON    (substr (strcase ICON) 1 1)
           IDT    (list (cons "X" 16)
                  (cons "?" 32)
                  (cons "!" 48)
                  (cons "i" 64)
            )
           ICON    (cdr (assoc ICON IDT))
         )
         (if (null ICON)
           (setq ICON 64)
         )
        )
        ((= (type ICON) 'INT)
         (if (null (member ICON (list 16 32 48 64)))
           (setq ICON 64)
         )
         (t (setq ICON 64))
        )
      )
      (if (not (equal (type MSG) 'STR))
    (setq MSG "Message HERE")
      )
      (cond ((null BTNS) (setq BTNS 0))
        ((= (type BTNS) 'INT)
         (if (or (< BTNS 0) (> BTNS 5))
           (setq BTNS 0)
         )
        )
        (t (setq BTNS 0))
      )
      (setq
    BTN (vlax-invoke-method sys 'popup MSG 0 TITLE (+ ICON BTNS))
      )
      (vlax-release-object sys)
    )
  )
  BTN
)
;;84.21 [功能] 当前目录文件搜索. 类似于 DIR /S 命令. 
;;用法: (vldos-findfile FilenameFullPathString[STRING] )
;;        (vldos-writefile NIL)
;;  参数1: 文件名. 可以包括扩展符 ("*" and "?").
;;        如果文件名描述符为 nil ,返回所有的文件包括子目录。
;;返回值: 包括所有符合条件的文件名 OR NIL
(Defun vldos-findfile (Filename        /         string->list
               getallfiles  allfiles     path
              )
  (Defun string->list (String / ID Rtn)
    (if    (null (setq ID (vl-string-search ";" String)))
      (setq Rtn (list String))
      (progn
    (while ID
      (setq    Rtn    (cons (substr String 1 ID) Rtn)
        String (substr String (+ 2 ID))
        ID     (vl-string-search ";" String)
      )
    )
    (setq Rtn (reverse (cons String Rtn)))
      )
    )
    Rtn
  )
  (Defun getallfiles (loc ext / path files rtn)
    (cond
      ((= loc "")
       (foreach    path (string->list (getvar "acadprefix"))
     (setq rtn (append rtn (getallfiles path ext)))
       )
      )
      ((vl-file-directory-p loc)
       (if (null (wcmatch loc "*\\"))
     (setq loc (strcat loc "\\"))
       )
       (foreach    files (vl-directory-files loc ext)
     (setq rtn (cons (vldos-formatpath (strcat loc files)) rtn))
       )
       (foreach    path (vl-directory-files loc nil -1)
     (if (and (/= path ".")
          (/= path "..")
         )
       (setq rtn (append rtn (getallfiles (strcat loc path) ext)))
     )
       )
      )
    )
    rtn
  )
  (setq    path     (vldos-formatpath (vl-filename-directory Filename))
    Filename (substr Filename (1+ (strlen path)))
    allfiles (acad_strlsort (getallfiles path filename))
  )
  allfiles
)
;;84.22 [功能] 合并两个文本文件
;;用法: (vldos-merge MergeBaseFilenameString[STRING] MergeFilenameString[STRING] EraseMergefileFlag[BOOLEAN] )
;;  参数1: 基文件名
;;  参数2: 将被合并的文件名
;;  参数3: 是否删除被合并文件的标志.
;;返回值: 合并后的文件名 OR NIL
(Defun vldos-merge (file1 File2 Erase / rtn)
  (if (and (setq file1 (findfile file1))
       (setq file2 (findfile file2))
      )
    (progn
      (vldos-writefile file1 (vldos-readfile file2) nil)
      (if Erase
    (vl-file-delete File2)
      )
      (setq rtn (findfile file1))
    )
  )
  rtn
)
;;85.1 [功能] 字符串分割为表  By 无痕
;;(str2lst1 str) 将输入的数据转换为字符串列表.-----------------------------梁雄啸.2004.3
;;测试: (str2lst1  "Hello 2World 12 5456.1568") = ("Hello" "2World" "12" "5456.1568")
(defun str2lst1 (str / i)
  (while (setq i (vl-string-search
           " "
           str
           (if i
             (+ 2 i)
             0
           )
         )
     )
    (setq str (vl-string-subst "\"\"" " " str i))
  )
  (read (strcat "(\"" str "\")"))
)
;;85.2 [功能] 字符串分割为表 -------梁雄啸.2004.3
;;测试:  (str2lst2  "Hello 2World 12 5456.1568")  -> ("Hello" "2World" "12" "5456.1568")
(defun str2lst2 (str /)
  (read
    (vl-list->string
      (apply
    'append
    (mapcar    '(lambda (x)
           (if (= 32 x)
             (list 34 32 34)
             (list x)
           )
         )
        (append (list 40 34) (vl-string->list str) (list 34 41))
    )
      )
    )
  )
)
;;85.3  [功能] 字符串分割为表 (纯autolspl的写法)-----梁雄啸.2004.3
;;测试: (str2lst3  "Hello 2World 12 5456.1568") = ("Hello" "2World" "12" "5456.1568")
(defun str2lst3 (str / i strlst str1)
  (setq    i 0
    str1 ""
  )
  (while (/= "" (setq s (substr str (setq i (1+ i)) 1)))
    (cond ((/= " " s) (setq str1 (strcat str1 s)))
      (T
       (setq strlst    (append strlst (list str1))
         str1    ""
       )
      )
    )
  )
  (if (/= str1 "")
    (append strlst (list str1))
    strlst
  )
)
;;85.4  [功能] 字符串分割为表 
(defun str2lst (str / i str1)
  (setq    i 0
    str1 ""
  )
  (while (/= "" (setq s (substr str (setq i (1+ i)) 1)))
    (setq str1 (strcat str1
               (if (= " " s)
             "\" \""
             s
               )
           )
    )
  )
  (read (strcat "(\"" str1 "\")"))
)
;;85.5 [功能] 字符串分割成表
;; 示例:   (MJ:Parse (getenv "ACAD") ";")                            ;;
;; Notes:     1. AutoLISP does not correctly interpret any character code outside the   ;;
;;               range of 1 to 255, so you cannot parse a null delimited string.        ;;
(defun MJ:Parse    (str delim / lst pos token)
  (setq pos (vl-string-search delim str))
  (while pos
    (setq lst (cons
        (if (= (setq token (substr str 1 pos)) delim)
          nil
          token
        )
        lst
          )
      str (substr str (+ pos 2))
      pos (vl-string-search delim str)
    )
  )
  (if (> (strlen str) 0)
    (setq lst (cons str lst))
  )
  (reverse lst)
)
;;85.6 [功能] 字符串函数   by qjchen@gmail.com
;;str是准备被处理的字符串，delim是一个字符串集合，其中的每一个字符都会被当作是分割符号
;;如 (MJ:delim "25 35 45 ; 55, 66 " " ;")=> ("25" "35" "45" "55," "66")
;;(MJ:delim "aa 10 b10x20.2" "")返回("aa 10 b10x20.2")
(defun MJ:delim (str delim / l1 l2)
  (setq str (vl-string->list str) delim (vl-string->list delim))
  (while str
    (if (not (member (car str) delim)) 
             (setq l1 (cons (car str) l1))
             (if l1 (setq l2 (cons (vl-list->string (reverse l1)) l2) l1 nil))
    )
    (setq str (cdr str))
  )
  (if l1 (setq l2 (cons (vl-list->string (reverse l1)) l2)))
  (reverse l2)
)
;;85.7 [功能] 用分隔符解释字符串成表 ;by fsxm
;;空格" "，不能用"" ，一个空格就转成一个字符
;;(fsxm-Split "aa 10 b10x20.2" " ")返回("aa" "10" "b10x20.2")
;;(fsxm-Split "aa 10 b10x20.2" "")死循环
(defun fsxm-Split (string strkey / po strlst xlen)
  (setq xlen (1+ (strlen strkey)))
  (while (setq po (vl-string-search strkey string))
    (setq strlst (cons (substr string 1 po) strlst))
    (setq string (substr string (+ po xlen)))
  )
  (reverse (cons string strlst))
)
;;85.8 [功能] 字符串分割(这是highflybird问答我的求助)
;;(Split "aa 10 b10x20.2" "")返回("AA" "10" "B10X20")
;;(Split "aa 10 b10x20.2" ".")返回("AA" "10" "B10X20" "2")
(defun Split (String Delimiter / str lst)
  (setq str (VL-STRING-TRANSLATE  Delimiter " " String))        ;首先替换
  (setq str (strcat "(" str ")"))                                                  ;然后加括号
  (setq lst (read str))                                                               ;读
  (setq lst (mapcar 'VL-PRINC-TO-STRING lst))                        ;转化
)
;;86.1 [功能] Exports the specified project to disk                             ;;
;; Arguments: The name of a project and the full path to a file             ;;
;; 示例:   (MJ:ExportProject "Johnson" "c:\\temp\\project.txt")                 ;;
(defun MJ:ExportProject    (pName fName / fh prj)
  (vl-load-com)
  (setq fh (open fName "w"))
  (if (setq prj    (vl-registry-read
          (strcat "HKEY_CURRENT_USER\\"
              (vlax-product-key)
              "\\Profiles\\"
              (getvar "CPROFILE")
              "\\Project Settings\\"
              pName
          )
          "RefSearchPath"
        )
      )
    (progn
      (write-line (strcat "[" pName "] ") fh)
      (foreach folder
              (MJ:Parse prj ";")
    (write-line folder fh)
      )
    )
    (princ "\nThe specified windows registry key is not exists."
    )
  )
  (close fh)
  (princ)
)
;;86.2 [功能] Imports a project exported by MJ:ExportProject                         ;;
;; Arguments: The full path to a file containing an exported project             ;;
;; 示例:   (MJ:ImportProject "c:\\temp\\project.txt")                     ;;
(defun MJ:ImportProject    (fName / pName fh l lst)
  (vl-load-com)
  (if (setq fh (open fName "r"))
    (progn
      (setq pName (read-line fh)
        pName (substr pName 2 (- (strlen pName) 2))
        lst      ""
      )
      (while (setq l (read-line fh))
    (setq lst (strcat lst l ";"))
      )
      (vl-registry-write
    (strcat    "HKEY_CURRENT_USER\\"
        (vlax-product-key)
        "\\Profiles\\"
        (getvar "CPROFILE")
        "\\Project Settings\\"
        pName
    )
    "RefSearchPath"
    (substr lst 1 (1- (strlen lst)))
      )
      (close fh)
    )
  )
  (princ)
)
;;87.1 [功能] 包围对象最小最大点列表
;; 示例:   (MJ:GetBoundingBox (car (entsel)))返回 ((左下角点)(右上角点))
(defun MJ:GetBoundingBox (ent / ll ur)  
  (vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
  (mapcar 'vlax-safearray->list (list ll ur))
)
;;87.2 [功能] 选择集的实体外矩形框 by gxl
(defun MJ:GetssBox (ss / i l1 l2 ll ur)
  (repeat (setq i (sslength ss))
    (vla-getboundingbox
      (vlax-ename->vla-object (ssname ss (setq i (1- i))))
      'll
      'ur
    )
    (setq l1 (cons (vlax-safearray->list ll) l1)
      l2 (cons (vlax-safearray->list ur) l2)
    )
  )
  (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
      '(min max)
      (list l1 l2)
  )
)
;;88.1 [功能] 返回曲线长度(不能返回块中曲线长度)
;; Arguments: The entity name of a line, arc, circle, polyline (heavy or lightweight).     ;;
;; 示例:   (MJ:GetCurveLength (car (entsel)))                             ;;
(defun MJ:GetCurveLength (curve /)
  (vl-load-com)
  (setq curve (vlax-ename->vla-object curve))
  (vlax-curve-getDistAtParam
    curve
    (vlax-curve-getEndParam curve)
  )
)
;;88.2 [功能] 返回曲线长度(包括块内曲线)
(defun CurveLen (/ CURVE-OBJ EN ENT)
  (if (setq ent (entsel "\n 点击曲线"))
    (progn
      (setq en (entget (car ent)))
      (if (= (cdr (assoc 0 en)) "INSERT")
    (setq ent (nentselp "" (cadr ent)))
      )
      (setq curve-obj (vlax-ename->vla-object (car ent)))
      (vlax-curve-getDistAtParam
    curve-obj
    (vlax-curve-getEndParam curve-obj)
      )
    )
  )
)
;;89 [功能] Returns the size of the specified file in bytes
;; 示例:   (MJ:GetFileSize "c:\\autoexec.bat")
;; Notes:     1. There are reports of VL-FILE-SIZE and ACET-FILE-SIZE malfunction on
;;               Win2K systems. Use this as a substitute. It requires SCRRUN.DLL.
;;          Visit the Microsoft scripting web site if you do not have it.    
(defun MJ:GetFileSize (fileName / fso file size)
  (vl-load-com)
  (if (findfile fileName)
    (progn
      (setq file (vlax-invoke-method *FSO* 'GetFile fileName)
        size (vlax-variant-value (vlax-get-property file 'Size))
      )
      (vlax-release-object file)      
    )
  )
  size
)
;;90.1 [功能] 返回文字样式字体高度
;; 示例:   (MJ:GetLastHeight "standard")
(defun MJ:GetLastHeight    (style)
  (vl-load-com)
  (vla-get-LastHeight
    (vla-Item
      (vla-get-TextStyles
    *DOC*
      )
      style
    )
  )
)
;;90.2 [功能] 设置文字样式字体高度
;; 示例:   (MJ:SetLastHeight "standard" 2.5)
(defun MJ:SetLastHeight (style height)
  (vl-load-com)
  (vla-put-LastHeight
    (vla-Item
      (vla-get-TextStyles
    *DOC*
      )
      style
    )
    height
  )
)
;;91 [功能] Returns the LISP value of an ActiveX variant.                     ;;
;; Arguments: An ActiveX variant or safearray.                             ;;
;; 示例:   (MJ:lisp-value MJ:Variant)                          ;;
;; Notes:     This function will recursively dig into a safearray and convert all     ;;
;;            values, including nested safearray's, into a LISP value.             ;;
(defun MJ:lisp-value (v)
  (cond
    ((= (type v) 'variant)
     (MJ:lisp-value (variant-value v))
    )
    ((= (type v) 'safearray)
     (mapcar 'MJ:lisp-value (safearray-value v))
    )
    (T v)
  )
)
;;92.1 [功能] Attach Extended Entity Data to an AutoCAD object.                 ;;
;; Arguments: An ActiveX object and an Extended Entity Data list in the same format as  ;;
;;            returned by GetXData.                             ;;
;; 示例:   (MJ:PutXData MJ:VlaObj '((1001 . "ACADX") (1000 . "MJ:StringData")))     ;;
;; Notes:     The Extended Entity Data application names as noted in the 1001 group     ;;
;;            code must be registered with the AutoLISP function REGAPP prior to        ;;
;;            attaching data to an object. See the AutoCAD help files for valid Extended;;
;;            Entity Data codes and values.                             ;;
(defun MJ:PutXData (vlaObj XData)
  (setq    XData
     (MJ:BuildFilter
       (mapcar
         '(lambda (item / key)
        (setq key (car item))
        (if (<= 1010 key 1033)
          (cons    key
            (vlax-variant-value
              (vlax-3d-point
                (cdr item)
              )
            )
          )
          item
        )
          )
         XData
       )
     )
  )
  (vla-setXData vlaObj (car XData) (cadr XData))
)
;;92.2 [功能] Get Extended Entity Data attached to an AutoCAD object.
;; Arguments: An ActiveX object and an application name that has been registed with     ;;
;;            the AutoLISP function REGAPP.                         ;;
;; 示例:   (MJ:GetXData MJ:VlaObj "ACADX")                          ;;
;; Notes:     Returns a list of Extended Entity Data attached to the object.         ;;
(defun MJ:GetXData (vlaObj AppID / xType XData)
  (vla-getxdata vlaObj AppID 'xType 'xData)
  (mapcar '(lambda (key val) (cons key (MJ:lisp-value val)))
      (vlax-safearray->list xType)
      (vlax-safearray->list xData)
  )
)
;;93.1 [功能] 面积标注             ;;
;; Arguments: The entity name of any object that supports the Area property          ;;
;;            (Arc, Circle, Ellipse, LWPolyline, Polyline, Region or Spline)         ;;
;; 示例:   (MJ:LabelArea (car (entsel)))                          ;;
;; Notes:     1. The first time an entity is labeled, the text will appear at the        ;;
;;               entity's start point or center point                     ;;
;;            2. Call MJ:LabelArea again to update a label. The label will update      ;;
;;          regardless of its current position                     ;;
;;            3. The are is formatted in the current units                 ;;
(defun MJ:LabelArea (ent / elist xdata text start area) 
  (regapp "LABELAREA")
  (setq    elist (entget ent '("LABELAREA"))
    xdata (assoc -3 elist)
    text  (if xdata
        (entget (handent (cdr (cadadr xdata))))
          )
    start (if (not text)
        (cdr (assoc 10 elist))
          )
    area  (vla-get-area (setq ent (*En2Obj* ent)))
  )
  (if (not text)
    (progn
      (setq
    text (vla-addtext
           (vla-get-block
         (vla-item
           *LOUTS*
           (cdr (assoc 410 elist))
         )
           )
           (rtos area)
           (vlax-3d-point start)
           0.25
         )
      )
    )
    (vla-put-textstring
      (setq text (*En2Obj* (cdr (assoc -1 text))))
      (rtos area)
    )
  )
  (vla-setxdata
    ent
    (vlax-make-variant
      (vlax-safearray-fill
    (vlax-make-safearray vlax-vbInteger '(0 . 1))
    '(1001 1005)
      )
    )
    (vlax-make-variant
      (vlax-safearray-fill
    (vlax-make-safearray vlax-vbVariant '(0 . 1))
    (list "LABELAREA" (vla-get-handle text))
      )
    )
  )
  (princ)
)
;;93.2 [功能] 面积求和
;;highflybird写的那个程序,长度、面积、惯性矩...什么都能
(defun ToTAreah (/ EN N SS TOT_AREA)
  (if (setq ss (ssget '((-4 . "<OR")
            (0 . "POLYLINE")
            (0 . "LWPOLYLINE")
            (0 . "CIRCLE")
            (0 . "ELLIPSE")
            (0 . "SPLINE")
            (0 . "REGION")
            (-4 . "OR>")
               )
           )
      )
    (progn
      (setq n -1)
      (setq tot_area 0)      
      (repeat (sslength ss)
    (setq en (ssname ss (setq n (1+ n))))
    (command "._area" "_O" en)
    (setq tot_area (+ tot_area (getvar "area")))    
      )     
    )
  )
  tot_area
)
;;94 [功能] 重命名布局
;; 示例:   (MJ:RenameLayout "Layout1" "MJ:Layout")
(defun MJ:RenameLayout (oldName newName)  
  (vla-put-name (vla-item *LOUTS* oldName) newName)
)
;;95 [功能] 返回打开文件列表
;; 示例: (MJ:ListDocuments)返回 ("Drawing1.dwg" "Drawing2.dwg")
(defun MJ:ListDocuments    (/ fname lst)
  (vl-load-com)
  (vlax-for doc    *DOCS*
    (setq
      lst (cons    (if (/= (setq fname (vla-get-fullname doc)) "")
          fname
          (vla-get-name doc)
        )
        lst
      )
    )
  )
  (reverse lst)
)
;;96 [功能] 返回布局列表
;; 示例:(MJ:ListLayouts)返回 ("Model" "MJ:Layout" "Layout2")
(defun MJ:ListLayouts (/ layouts c lst lay)
  (vl-load-com)
  (setq    layouts    (vla-get-layouts
          *DOC*
        )
    c    -1
  )
  ;;(vlax-for lay layouts (setq lst (cons (vla-get-name lay) lst)))
  (repeat (vla-get-count layouts)
    (setq lst (cons (setq c (1+ c)) lst))
  );(2 1 0)
  (vlax-for lay    layouts
    (setq lst
       (subst
         (vla-get-name lay)
         (vla-get-taborder lay)
         lst
       )
    )
  )
  (reverse lst)
)
;;97 [功能] 窗口左下角空间切换是否显示
(defun MJ:ToggleLayouts    (/ prefDisplay)
  (vl-load-com)
  (setq    prefDisplay
     (vla-get-Display
       (vla-get-Preferences
         *ACAD*
       )
     )
  )
  (vla-put-DisplayLayoutTabs
    prefDisplay
    (if    (= (vla-get-DisplayLayoutTabs prefDisplay) :vlax-true)
      :vlax-false
      :vlax-true
    )
  )
  (princ)
)
;;98.1 [功能] 模型空间背景色在空白之间切换
(defun MJ:ToggleMSBackground (/ prefDisplay)
  (vl-load-com)
  (setq    prefDisplay (vla-get-Display
              (vla-get-Preferences *ACAD*)
            )
    color        (vlax-variant-value
              (vlax-variant-change-type
            (vla-get-GraphicsWinModelBackgrndColor prefDisplay)
            vlax-vbLong
              )
            )
  )
  (vla-put-GraphicsWinModelBackgrndColor
    prefDisplay
    (vlax-make-variant
      (if (= color 0)
    16777215
    0
      )
      vlax-vbLong
    )
  )
  (princ)
)
;;98.2[功能] 布局空间背景色在空白之间切换
(defun MJ:TogglePSBackground (/ prefDisplay)
  (vl-load-com)
  (setq    prefDisplay (vla-get-Display
              (vla-get-Preferences *ACAD*)
            )
    color        (vlax-variant-value
              (vlax-variant-change-type
            (vla-get-GraphicsWinLayoutBackgrndColor prefDisplay)
            vlax-vbLong
              )
            )
  )
  (vla-put-GraphicsWinLayoutBackgrndColor
    prefDisplay
    (vlax-make-variant
      (if (= color 0)
    16777215
    0
      )
      vlax-vbLong
    )
  )
  (princ)
)
;;99.1 [功能] 表->二维表
;;示例(list->2pair (list (getpoint)(getpoint)(getpoint)(getpoint)))
;;示例(list->2pair '(1 2 3 4 5 6)),返回((1 2) (3 4) (5 6))
(defun list->2pair (old / new)
  (while (setq new (cons (list (car old) (cadr old)) new)
           old (cddr old)
     )
  )
  (reverse new)
)
;;99.2 [功能] 表->三维表
;;示例(list->3pair '(1 2 3 4 5 6)),返回((1 2 3) (4 5 6))
(defun list->3pair (old / new)
  (while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
           old (cdddr old)
     )
  )
  (reverse new)
)
;;99.3 [功能] 获取多段线顶点列表(见46)
;;多段线顶点((-1736.57 2913.7) (-1618.83 2795.96) (-1413.66 2795.96))
;;vla-Get-Coordinates不能取得高程
(defun LwpolinePoints (/ temp)
  (setq    temp (vla-Get-Coordinates (*En2Obj* (car (entsel)))))
  (list->2pair (vlax-safearray->list (vlax-variant-value temp)))
)
;;99.4 [功能] 两对象交点
;;  mode:acExtendNone,acExtendThisEntity,acExtendOtherEntity,acExtendBoth
(defun All-intersectwith (obj1 obj2 mode / INT IPLIST)
  (defun list->3pair (old / new)
    (while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
         old (cdddr old)
       )
    )
    (reverse new)
  )
  (setq int (vla-IntersectWith obj1 obj2 mode))
  (setq    iplist (vl-catch-all-apply
         'vlax-safearray->list
         (list (vlax-variant-value int))
           )
  )
  (if (vl-catch-all-error-p iplist)
    nil
    (list->3pair iplist)
  )
)
;;100.1 [功能] 判断是否val对象?
(defun Is-Vla-Object (obj) (equal (type obj) 'vla-object))
;;100.2 [功能] 判断是否字符串
(defun Is-String (arg) (equal (type arg) 'str))
;;100.3 [功能] 判断是否实数?
(defun Is-Real (arg) (equal (type arg) 'real))
;;100.4 [功能] 判断是否ename对象?
(defun Is-Ename (arg) (equal (type arg) 'ename))
;;100.5 [功能] 判断是否变体?
(defun Is-Variant (arg) (equal (type arg) 'variant))
;;100.6 [功能] 判断 X 是否是选择集且长度不为 0
(defun MJ:ssP (x)
  (and (= (type X) 'PICKSET) (> (sslength X) 0))
)
;;100.7 [功能] 是否为点对表
;;示例(MJ:ConsP lst) 
(defun MJ:ConsP (lst)
  (and (vl-consp lst)
       (not (vl-list-length lst))
  )
)
;;101 [功能] 多段线顶点的连续样式产生线型
;;示例 (MJ:ApplyLtypeGen (car (entsel)))
(defun MJ:ApplyLtypeGen (object / obj)
  (setq object (MJ:MakeObject object))    ;不是Vla对象,则转换成vla对象
  (vla-put-LinetypeGeneration object :vlax-True)
)
;;示例 (MJ:Put-ByLayer (vlax-ename->vla-object (car (entsel))))
;;102.1 [功能] 使对象颜色随层
(defun MJ:Put-ByLayer (obj)
  (if (vlax-write-enabled-p obj)
    (progn
      (vla-put-Color obj 255)
      ;(vla-put-Linetype obj ...);; <-- I need to figure this out!!!
    )
  ); endif
)
;;102.2 [功能] 设置当前颜色
;;acColor 颜色值字符串："1" "2" "3" ... "bylayer" 
(defun MJ:myColor (acColor)
  (vla-setVariable *DOC* "cecolor" acColor)
)
;;103 [功能] 打印配置
(defun MJ:PlotConfigs    (/ ITEMNAME OUT)
  (defun MJ:Name (obj)
    (if    (vlax-property-available-p obj 'Name)
      (vlax-get-property obj 'Name)
      "<NONE_NAME>"
    )
  )
  (vlax-for each (vlax-get-property
           *DOC*
           'PlotConfigurations
         )
    (if    (vlax-property-available-p each 'GetPlotDeviceNames)
      (setq out (cons (vlax-get-property each 'GetPlotDeviceNames) out))
    )
    (setq itemname (MJ:Name each)
      out       (cons itemname out)
    )
  )
  out
)
;;104 [功能] 打印设备列表
(defun MJ:GetPlotDevices ()
  (vl-load-com)
  (vlax-safearray->list
    (vlax-variant-value
      (vla-getplotdevicenames
    (vla-item (vla-get-layouts
            *DOC*
          )
          "Model"
    )
      )
    )
  )
)
;;105.1 [功能] 清除所有捕捉，与按F3有不同处(参见77.4)
(defun MJ:SnapOff ()
  (vla-put-ObjectSnapMode *DOC* :vlax-false)
)
;;105.2 [功能] MJ:SnapOn之后下面函数只启用端点捕捉
(defun MJ:SnapOn ()
  (vla-put-ObjectSnapMode *DOC* :vlax-true)
)
;;106.1 [功能] 打开一个文件
;;示例: (MJ:OpenDwg "D:\\紫金防雨.dwg")(MJ:OpenDwg "D:\\DrawingA.dxf")
(defun MJ:OpenDwg (fullname)
  (command "vbastmt"
       (strcat "AcadApplication.Documents.Open "
           (chr 34) fullname (chr 34)
       )
  )
)
;;106.2 [功能] 打开一个文件
;;示例(MJ:OpenDwg1 "D:\\紫金防雨.dwg")(MJ:OpenDwg1 "D:\\DrawingA.dxf")
(defun MJ:OpenDwg1 (fullname / *DOC*)
  (setq *DOCS* (vla-get-Documents (vlax-get-acad-object)))
  (vla-open *DOCS* fullname)
)
;;106.3 [功能] 将一文件输入到当前文件中
;;示例(MJ:OpenDwg2 "D:\\DrawingA.dxf")
(defun MJ:OpenDwg2 (fullname / *DOC*)
  (setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object)))
  (vla-import *DOC* fullname (vlax-3d-point (list 0 0 0)) 1)
)
;;107.1 [功能] 原位复制Vla
;;obj    图元对象，或图元名
(defun myCopy (obj)  
  (if (= (type obj) 'ENAME)
    (setq obj (*En2Obj* obj))
  )
  (vla-copy obj)
)
;;107.2 [功能] 原位复制ename
(entmake (entget ename))
;;107.3 [功能] 原位置复制VLA选集
(vlax-map-collection SS 'vla-copy)
;;107.4 [功能] 删除VLA选择集
(vlax-map-collection SS 'vla-delete)
;;107.5 [功能] 块内原地复制 By xshrimp
(defun MJ:BlockNentselX    (/ BLOCKREFOBJ I NENT OBJ OBJENT)
  ;;生成无名块
  (defun make*ublock (obj / blockobj)
    (setq blockObj (vla-add (vla-get-Blocks *DOC*)
                (vlax-3d-point (list 0 0 0))
                "*U"
           )
    )
    (vla-CopyObjects
      *DOC*
      (vlax-safearray-fill
    (vlax-make-safearray vlax-vbObject (cons 0 0))
    (list obj)
      )
      blockObj
    )
    (vla-delete obj)
    (vla-get-name blockObj)
  )
  ;; 主程序
  (if (= (length (setq nent (nentsel))) 4)
    (progn (entmake (entget (car nent)))
       (setq objent    (*En2Obj* (entlast))
         i    0
       )
       (foreach n (last nent)
         (setq obj (*En2Obj* n))
         (setq blockRefObj
            (vla-InsertBlock
              *MS*
              (vla-get-InsertionPoint obj)
              (make*ublock objent)
              (vla-get-xScaleFactor obj)
              (vla-get-yScaleFactor obj)
              (vla-get-zScaleFactor obj)
              (vla-get-Rotation obj)
            )
         )
         (setq i (1+ i))
         (if (> i 1)
           (command "_.explode" (entlast))
         )
         (setq objent (*En2Obj* (entlast)))
       )                
       (command "_.explode" (entlast))
       (sssetfirst nil (ssget "p"))
    )
  )
  (prin1)
)
;;107.6 [功能] 块内原地复制 by highflybird
(defun MJ:BlockNentselH (/ *SPACE BLK ENT LX LY LZ MAT NEW OBJ Q REF RET SCLMAT SX SY SZ TRSMAT V VV VX VY VZ)
  ;; 匿名块程序
  (defun make-anonymous-block (obj / BLKOBJ origin bkName *space)
    (setq origin (vlax-3d-point '(0.0 0.0 0.0)))
    (setq blkobj (vla-add (vla-get-blocks *doc*) origin "*U"))
    (setq bkName (vla-get-name blkobj))
    (vlax-invoke *doc* 'copyobjects (list obj) blkobj)
    (if    (zerop (vla-get-ActiveSpace *DOC*))
      (setq *space (vla-get-PaperSpace *doc*))
      (setq *space (vla-get-modelspace *doc*))
    )
    (vla-insertblock *space origin bkName 1 1 1 0)
    (vla-put-Explodable blkobj :vlax-true)
    blkobj
  )
  ;; 矩阵转置
  ;; MAT:trp Transpose a matrix -Doug Wilson- 
  (defun MAT:trp (m)
    (apply 'mapcar (cons 'list m))
  )
  ;; 向量的矩阵变换(向量乘矩阵) 
  ;; Matrix x Vector - Vladimir Nesterovsky 
  ;; Args: m - nxn matrix, v - vector in R^n 
  (defun MAT:mxv (m v)
    (mapcar (function (lambda (r) (apply '+ (mapcar '* r v))))
        m
    )
  )
  ;; 矩阵相乘 
  ;; MAT:mxm Multiply two matrices -Vladimir Nesterovsky- 
  (defun MAT:mxm (m q)
    (mapcar (function (lambda (r) (MAT:mxv (MAT:trp q) r))) m)
  )
  ;; 主程序
  (setq ret (nentselp))
  (if (null ret)
    (exit)
  )
  (setq mat (caddr ret))        ;这个是变换矩阵
  (setq vv (reverse (cdr (reverse mat)))) ;去掉第四行(0 0 0 1)
  (setq vX (mapcar 'car vv))        ;X 向量
  (setq vY (mapcar 'cadr vv))        ;Y 向量
  (setq vZ (mapcar 'caddr vv))        ;Z 向量
  (setq lX (distance vX '(0 0 0)))    ;X 比例因子
  (setq lY (distance vY '(0 0 0)))    ;Y 比例因子
  (setq lZ (distance vZ '(0 0 0)))    ;Z 比例因子
  (setq ent (car ret))
  (setq obj (*En2Obj* ent))
  (if (and (equal lX lY 1e-8) (equal lY lZ 1e-8)) ;如果是均匀缩放
    (progn
      (if (zerop (vla-get-ActiveSpace *DOC*))
    (setq *space (vla-get-PaperSpace *doc*))
    (setq *space (vla-get-modelspace *doc*))
      )
      (vlax-invoke *doc* 'copyobjects (list obj) *space)
                    ;则仅仅是copyObjects方式添加到空间中
      (setq new (*En2Obj* (entlast)))
      (vla-transformby new (vlax-tmatrix mat)) ;然后再矩阵变换
    )
    (progn
      (setq blk (make-anonymous-block obj)) ;先做一个匿名图块
      (setq ref (*En2Obj* (entlast))) ;插入块参照
      (setq sX (/ 1 lx))        ;非均匀缩放则要取得各个比例值
      (setq sY (/ 1 lY))
      (setq sZ (/ 1 lZ))
      (setq sclMat (list (list sX 0 0 1);乘以一个比例缩放矩阵使得比例均匀
             (list 0 sY 0 1)
             (list 0 0 sZ 1)
             (list 0 0 0 1)
           )
      )
      (setq trsmat (MAT:mxm mat sclMat)) ;得到一个均匀缩放的变换矩阵
      (vla-transformby ref (vlax-tmatrix trsmat)) ;变换参照
      ;;最后需要变换回去
      (vla-put-xscalefactor ref (* (vla-get-xscalefactor ref) lX))
      (vla-put-yscalefactor ref (* (vla-get-yscalefactor ref) lY))
      (vla-put-zscalefactor ref (* (vla-get-zscalefactor ref) lZ))
      (vlax-put ref 'insertionpoint (mapcar 'last vv))
      ;;(vla-Explode ref)
      (command "explode" "L")        ;炸开匿名块参照
      ;;(vla-delete ref)
      (vla-delete blk)            ;删除匿名块定义
    )
  )
  (princ)
)
;;107.7 [功能] 块内原地复制 by GSLS(SS)
;; 示例 : (MJ:BlockNentsel "My God:")
(defun MJ:BlockNentsel (msg / EN EN1 ENT INS MAT OBJ PT X Y)
  (setq en (Nentsel msg))
  (if (= (length en) 4)
    (progn
      (setq en1    (car en)
        pt    (cadr en)
        mat    (caddr en)
        ins    (last mat)
        mat    (reverse (cdr (reverse mat)))
        mat    (append
          (mapcar '(lambda (x y)
                 (append x (list y))
               )
              mat
              ins
          )
          '((0. 0. 0. 1.))
        )
        ent    (entget en1 '("*"))
        ent    (vl-remove (assoc -1 ent) ent)
        en1    (entmakex ent)
      )
      (if en1
    (progn
      (setq obj (*En2Obj* en1))
      (vla-TransformBy obj (vlax-tmatrix mat))
      (setq en1 (*Obj2En* obj))
    )
      )
      (list en1 pt T)
    )
    (append en (list nil))
  )
)
;;108 [功能] 输出 WMF SAT EPS DXF BMP格式文件
;;fileName    输出文件名
;;Extension   输出文件格式：WMF SAT EPS DXF BMP 之一 
;;SelectonSet 选择集对象，如果Extension=EPS/DXF，则忽略（但必须有效！），而输出整个图形
(defun myExport    (fileName Extension SelectonSet /)
  (vla-export *DOC* fileName Extension SelectonSet)
)
;;109 [功能] 移动Move
(defun myMove (moveEnt fromPt toPt / moveType point1 point2)
  (setq    point1 (vlax-3d-point fromPt)
    point2 (vlax-3d-point toPt)
  )
  (setq moveType (type moveEnt))
  (cond
    ((= moveType 'ENAME)
     (setq obj (*En2Obj* moveEnt))
     (vla-move obj point1 point2)
     1
    )
    ((= moveType 'PICKSET)
     (setq sn (sslength moveEnt)
       i  0
     )
     (while (< i sn)
       (setq si (ssname moveEnt i))
       (setq obj (*En2Obj* si))
       (vla-move obj point1 point2)
       (setq i (1+ i))
     )
    )
  )
)
;;110 [功能] 偏移
;;对逆时针方向的图形 dis >0 向外偏移，<0 为向内偏移
(defun myOffset    (obj dis / wObj offsetObj)
  (setq wObj obj)
  (if (= (type obj) 'ENAME)
    (setq wObj (*En2Obj* obj))
  )
  (setq offsetObj (vla-Offset wObj dis))
)
;;111 [功能] 退出Acad
(defun myQuit ()
  (vla-Quit *ACAD*)
)
;;112 [功能] 重生成
(defun myRegen ()
  (vla-Regen *ACAD* :vlax-true)
)
;;113 [功能] 旋转(见133.1)
(defun myRotate    (obj basePoint RotateAngle / wObj bPoint rAngle)
  (setq wObj obj)
  (if (= (type obj) 'ENAME)
    (setq wObj (*En2Obj* obj))
  )
  (setq bPoint (vlax-3d-point basePoint))
  (setq rAngle (/ (* RotateAngle pi) 180.0))
  (vla-Rotate wObj bPoint rAngle)
)
;;114.1 [功能] 多段线添加节点Vertex
;;pt节点;index序号
(defun MJ:AddVertex    (PLineObj index pt / newVertex)
  (setq newVertex (vlax-make-safearray vlax-vbDouble (cons 0 1)))
  (vlax-safearray-fill newVertex pt)
  (vla-AddVertex PLineObj index newVertex)
)
;;114.2 [功能] 多段线修改节点Vertex
;;示例 (MJ:ChangeVertex (car(entsel)) (trans (getpoint) 0 1) 1)
(defun MJ:ChangeVertex (pl pt index)
  (if (= 'ename (type pl))
    (setq pl (*En2Obj* pl))
  )
  (if (= "AcDbPolyline" (vla-get-ObjectName pl))
    (setq pt (list (car pt) (cadr pt)))
  )
  (VL-CATCH-ALL-APPLY
    'vla-put-coordinate
    (list
      pl
      index
      (vlax-make-variant
    (vlax-safearray-fill
      (vlax-make-safearray
        vlax-vbdouble
        (cons 0 (1- (length pt)))
      )
      pt
    )
      )
    )
  )
)
;;114.3 [功能] 多段线除重点
(defun c:DESP (/ DATA ENP L N NEWDATA SEL)
  (princ "\n ★☆★选择需要除重点的多段线：")
  (if (SetQ Sel (SsGet (list (cons 0 "lwpolyline"))))
    (Repeat (setq L (SsLength Sel))
      (SetQ data (entget (SsName Sel (setq L (1- L)))))
      (setq n -1 newdata nil)
      (while (setq enp (nth (setq n (1+ n)) data))
    (if (and (member enp newdata) (= 10 (car enp)))
      (setq n (+ n 3))
      (setq newdata (cons enp newdata))
    )
      )
      (entmod (reverse newdata))
    )
  )
  (princ)
)
;;114.4 [功能] 动态绘制指引标注框符号 By Gu_xl 2012.07.17 
(defun c:zybz (/ P1 P2 EN OBJ EL GR PT PA NEW FILLETFlag R kd *error*)
  (defun *error* (s)
    (princ s)
    (if    obj
      (vla-delete obj)
    )
    (if    new
      (vla-delete new)
    )
    (princ)
  )
  (if (and (setq p1 (getpoint "\n左下角点: "))
       (setq p2 (GETCORNER p1 "\n右上角点: "))
      )
    (progn
      (command "_.rectang" p1 p2)
      (setq en    (entlast)
        obj    (vlax-ename->vla-object en)
      )
      (setq r (getvar 'FILLETRAD))
      (initget "Yes No Set")
      (setq kd
         (cond
           ((setq kd
               (getkword
             (strcat
               "\n矩形是否圆角(R="
               (rtos r 2 3)
               ")[圆角Yes/不圆角No/设置圆角半径Set]<No>"
             )
               )
        )
           )
           ("No")
         )
      )
      (if (= kd "Set")
    (setq r (getdist (strcat "\n输入圆角半径<" (rtos r 2 3) ">")))
      )
      (if (null r)
    (setq r (getvar 'FILLETRAD))
      )
      (if (and (or (= kd "Set") (= kd "Yes")) (not (equal r 0 1e-6)))
    (progn (setvar 'FILLETRAD r)
           (command "_.FILLET" "p" en)
           (setq FILLETFlag t)
    )
      )
      (while (= 5 (car (setq gr (grread t 15))))
    (redraw en 2)
    (if new
      (vla-delete new)
    )
    (setq pt (cadr gr))
    (setq pa (vlax-curve-getParamAtPoint
           en
           (vlax-curve-getclosestpointto en pt)
         )
    )
    (cond
      ((equal pa (fix pa) 1e-6) (setq pa (1- (fix pa))))
      (t (setq pa (fix pa)))
    )
    (if (MINUSP pa)
      (setq pa 0)
    )
    (if (and FILLETFlag (member pa '(1 3 5 7)))
      (setq pa (1- pa))
    )
    (setq p1 (vlax-curve-getPointAtParam en (+ pa 0.35))
          p2 (vlax-curve-getPointAtParam en (+ pa 0.65))
    )
    (vla-copy obj)
    (setq new (vlax-ename->vla-object (entlast)))
    (vla-AddVertex
      new
      (+ 1 pa)
      (vlax-make-variant
        (vlax-safearray-fill
          (vlax-make-safearray
        vlax-vbdouble
        '(0 . 1)
          )
          (list (car p1) (cadr p1))
        )
      )
    )
    (vla-AddVertex
      new
      (+ 2 pa)
      (vlax-make-variant
        (vlax-safearray-fill
          (vlax-make-safearray
        vlax-vbdouble
        '(0 . 1)
          )
          (list (car
              (trans pt 1 0)
            )
            (cadr
              (trans pt 1 0)
            )
          )
        )
      )
    )
    (vla-AddVertex
      new
      (+ 3 pa)
      (vlax-make-variant
        (vlax-safearray-fill
          (vlax-make-safearray
        vlax-vbdouble
        '(0 . 1)
          )
          (list (car p2) (cadr p2))
        )
      )
    )
      )
      (entdel en)
    )
  )
  (princ)
)
;;115 [功能] 文件名已经保存，返回T；新建一文件，未命名保存过，返回 nil
(defun MJ:DwgNamed-p ()  
  (= 1 (getvar "dwgtitled"))
)
;;116.1 [功能] 缩放整个图形
(defun MJ:ZoomAll()  
  (vla-ZoomAll *ACAD*)
)
;;116.2 [功能] 缩放到实际范围
(defun MJ:ZoomExtents()  
  (vla-ZoomExtents *ACAD*)
)
;;116.3 [功能] pt中心点缩放1
(defun MJ:ZoomCenter1 (pt)
  (vla-ZoomCenter *ACAD* (vlax-3d-point pt) 1.0)
)
;;116.4 [功能] pt中心点缩放2
(defun MJ:ZoomCenter2 (centerPoint zoomHeight)
  (vla-ZoomCenter
    *ACAD*
    (vlax-3d-point centerPoint)
    zoomHeight
  )
)
;;116.5 [功能] 两点窗口缩放
(defun MJ:ZoomWindow (p1 p2)
  (vla-ZoomWindow *ACAD*
    (vlax-3d-point p1) (vlax-3d-point p2)
  )
)
;;116.6 [功能] 视口比例缩放-放大2倍
(defun MJ:ZoomScale ()
  (vla-ZoomScaled *ACAD* 2.0 1)
)
;;116.7 [功能] 视口比例缩放
(defun MJ:ZoomScaled (scaleFactor scaleType / AcadObject sType)
  (setq sType scaleType)
  (if (or (not scaleType) (= scaleType ""))
    (setq sType acZoomScaledRelative)    ;和视图相关，或acZoomScaledAbsolute与图形范围
  )
  (vla-ZoomScaled
    *ACAD*
    scaleFactor
    scaleType
  )
)
;;116.8 [功能] 返回上一视图
(defun MJ:ZoomPrevious ()
  (vla-ZoomPrevious *ACAD*)
)
;;117.1 [功能] 在当前视图状况下将图形单位转换为像素
(defun MJ:U2P (UN)
  (* UN (/ (cadr (getvar 'SCREENSIZE)) (getvar 'VIEWSIZE)))
)
;;117.2 [功能] 在当前视图状况下将像素转换为图形单位
(defun PIX2UNITS (pix)
  (* pix (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))))
)
;;117.3 [功能] 返回当前视窗左下角和右上角 坐标
(defun viewpnts    (/ a b c d x)
  (setq    b (getvar "viewsize")
    c (car (getvar "screensize"))
    d (cadr (getvar "screensize"))
    a (* b (/ c d))
    x (setq x (getvar "viewctr"))
    x (trans x 1 2)
    c (list (- (car x) (/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0)
    d (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0)
    c (trans c 2 1)
    d (trans d 2 1)
  )
  (list c d)
)
;;117.4 [功能] pickbox大小
(defun MJ:pickboxsize ()
  (* (/ (getvar "pickbox") (cadr (getvar "screensize")))
     (getvar "viewsize")
  )
)
;;118.1 [功能] 获取 0~1 之间的随机数 (by zml84)
(defun MJ:RAD ()
  (/ (rem (getvar "CPUTICKS") 1984) 1983)
)
;;118.2 [功能] 获取 0~7 之间的随机数
(defun ZL-RAND ()
 (fix (* 7 (/ (rem (getvar "CPUTICKS") 1984) 1983)))
)
;;119.1 [功能] 将 ACI 索引颜色转换成 RGB 配色系统
(defun MJ:ACI->RGB (ACI / COL)
  (setq COL (vla-get-truecolor (vla-get-ActiveLayer *DOC*)))
  (if (not (vl-catch-all-apply 'vla-put-ColorIndex (list COL ACI))
      )
    (list (vla-get-red COL)
      (vla-get-green COL)
      (vla-get-blue COL)
    )
  )
)
;;119.2 [功能] 将 RGB 配色系统转换成 ACI 索引颜色 
(defun MJ:RGB->ACI (R G B / COL ACI)
  (setq COL (vla-get-truecolor (vla-get-ActiveLayer *DOC*)))
  (vl-catch-all-apply
    '(lambda ()
       (vla-SetRGB COL R G B)
       (setq ACI (vla-get-ColorIndex COL))
     )
  )
  ACI
)
;;120.1 [功能] 选择集->图元列表
(defun MJ:SS->LIST (SS)
  (vl-remove-if-not 'Is-Ename (mapcar 'cadr (ssnamex SS)))
)
;;120.2 [功能] 选择集->图元列表 By caiqs
(defun ss->lst (ss / retu)
  (setq retu (apply 'append (ssnamex ss)))
  (setq retu (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) retu))
)
;;120.3 [功能] Vla集合->图元列表
(defun VlaSS (VlaSS / lst)
  (vlax-for x VlaSS
    (setq lst (cons (vlax-vla-object->ename x) lst))
  )
)
;;120.4 [功能] 图元列表->选择集
(defun MJ:Sel-List->SS    (Lst / en ss kk)
  (setq    ss (ssadd)
    kk 0
  )
  (foreach en Lst
    (ssadd en ss)
    (setq kk (1+ kk))
  )
  ss
)
;;120.5 [功能] 图元列表->选择集 By caiqs
(defun lst->ss (lst / ss)
  (setq ss (ssadd))
  (last (mapcar '(lambda (x) (ssadd x ss)) lst))
)
;;121 [功能] 根据当前文档的图形单位精度将实数转换为字符串
;; [参数] REL----实数
(defun MJ:RTOS (REL / DZIN)
  (setq DZIN (getvar 'DIMZIN))
  (setvar 'DIMZIN 0)
  (setq REL (rtos REL 2 (getvar 'LUPREC)))
  (setvar 'DIMZIN DZIN)
  REL
)
;;122.1 [功能] 遍历选择集对所包含的图元进行指定函数操作
;; [参数] SS----选择集
;;        FUN---函数名
;; [返回] 包含每个图元的操作结果的表
(defun MJ:SS-MAP (SS FUN / N LST)
  (repeat (setq N (sslength SS))
    (setq LST (cons (apply FUN (list (ssname SS (setq N (1- N))))) LST))
  )
  LST
)
;;122.2 [功能] 遍历选择集对所包含的图元进行指定函数操作
;; [参数] SS----选择集
;;        FUN---函数名
;; [返回] 最后一个图元的操作结果
(defun MJ:SS-FOR (SS FUN / N)
  (repeat (setq N (sslength SS))
    (apply FUN (list (ssname SS (setq N (1- N)))))
  )
)
;;123 [功能] 获取当前 AutoCAD 的版本
(defun MJ:ACAD-VAR () (atof (getvar "ACADVER")))
;;124 [功能] 获取 DXF 组码值
(defun MJ:DXF (IT LST)
  (cdr (assoc IT LST))
)
;;125.1 [功能] 获取在图元 en 之后产生的图元列表
(defun MJ:EntNextAll (EN / LST)
  (if EN
    (while (setq EN (entnext EN))
      (if (not (member (cdr (assoc 0 (entget EN)))
               '("ATTRIB" "VERTEX" "SEQEND")
           )
      )
    (setq LST (cons EN LST))
      )
    )
  )
  (reverse LST)
)
;;125.2 [功能] 获取在图元 en 之后产生的图元的选择集
(defun MJ:ss-entnext (en / ss)
  (if en
    (progn
      (setq ss (ssadd))
      (while (setq en (entnext en))
    (if (not (member (cdr (assoc 0 (entget en)))
             '("ATTRIB"
               "VERTEX"
               "SEQEND"
              )
         )
        )
      (ssadd en ss)
    )
      )
      (if (zerop (sslength ss))
    (setq ss nil)
      )
      ss
    )
    (ssget "_x")
  )
)
;;126 [功能] 打印列表中的数据
(defun MJ:Print-List (LST) (mapcar 'princ LST))
;;127 [功能] 更新组码
;; (entmodEnt 图元 组码 组码新值 TF) TF为nil时不更新图元
(defun MJ:entmodEnt (ent a vale TF / ENTLIST)
  (setq entlist (entget ent))
  (entmod (subst (cons a vale) (assoc a entlist) entlist))
  (if TF
    (entupd ent)
  )
  ent
)
;;128.1 [功能] 选择集->无名块
;;示例(MJ:BLK-MakeUnNameBlock (ssget))
;;注意 函数对选择集中存在具有属性的图块及复杂多义线无效
(defun MJ:BLK-MakeUnNameBlock (ss / count entlist ent blk pt)
  (setq pt (car (MJ:GetssBox ss)))
  (entmake (list '(0 . "BLOCK")
         '(2 . "*U")
         '(70 . 1)
         (cons 10 pt)
       )
  )
  (setq count 0)
  (repeat (sslength ss)
    (setq entlist (entget (setq ent (ssname ss count))))
    (setq count (1+ count))
    (entmake entlist)
  )
  (setq count 0)
  (repeat (sslength ss)
    (setq ent (ssname ss count))
    (setq count (1+ count))
    (entdel ent)
  )
  (setq blk (entmake '((0 . "ENDBLK"))))
  (if (princ blk)
    (entmake (list (cons 0 "INSERT")
           (cons 2 blk)
           (cons 10 pt)
         )
    )
  )
  blk
)
;;128.2 [功能] 用 [选择集/obj表] 做成一个块
(defun MJ:add-Block (ss/objlst name InsertionPoint / block blocks)
  (if (atom ss/objlst)
    (setq ss/objlst (mapcar 'vlax-ename->vla-object
       (MJ:SS->LIST ss/objlst)
      )
    )
  )
  (setq blocks (vla-get-Blocks *doc*))
  (setq block (vla-add Blocks (vlax-3d-point InsertionPoint) name))
  (vlax-invoke *doc* 'CopyObjects ss/objlst block)  block
)
;;128.3 [功能] 选择集做成一个块
(defun MJ:MakeBlock (ss / A)  
  (setq A (rtos (* (getvar "CDATE") 1E8)))
  (if ss
    (command "_.BLOCK" A "0,0" ss "")
  )
  ;;(command "_.INSERT" A "@" "" "" "")
)
;;129.1 [功能] 删除表中相同图元
(defun MJ:delsame (l)
  (if L
    (cons (car L) (MJ:delsame (vl-remove (car L) (cdr L))))
  )
)
;;129.2 [功能] 深入递归删除重复出现的原子,每个嵌套的表也要除重
(defun gxl-ListDumpAtomAll (Lst / tmp)
  (if Lst
    (cons (if (= 'list (type (setq tmp (car Lst))))
        (gxl-ListDumpAtomAll tmp)
        tmp
      )
      (gxl-ListDumpAtomAll
        (vl-remove
          (car Lst)
          (cdr Lst)
        )
      )
    )
  )
)
;;129.3 [功能] 剔除表元素 By 无痕
;;提示; 等同于: (vl-remove at list) 
;;(MJ:removeat "a" '(58 3 (a . 8) "a" 4.5)) -> (58 3 (A . 8) 4.5)
(defun MJ:removeat (at lst)        ;at=atom
  (apply 'append (subst nil (list at) (mapcar 'list lst)))
)
;;130 [功能] 获得特定符号表的列表。 
;;   有效符号表名称为Layer,Ltype,Viewx,Style,Block,Appid,Ucs,Dimstyle和Vport。
(defun MJ:get-tblnext (table-name / lst d)
  (while (setq d (tblnext table-name (null d)))
    (setq lst (cons (cdr (assoc 2 d)) lst))
  )
  (reverse lst)  
)
;;131.1 [功能] 返回a在表lst中的位置 or nil
(defun MJ:position (a lst / b)
  (if (setq b (member a lst))
    (progn (setq b (- (length lst) (length b))))
  )
  b
)
;;131.2 [功能] 返回a在表lst中的位置 or nil
;; 示例(position x '(a b c)) -> nil, (position 'b '(a b c d)) -> 1
(defun position    (x lst / ret)
  (if (not (zerop (setq ret (length (member x lst)))));x不在表中返回nil
    (- (length lst) ret)
  )
)
;;131.3 [功能] 从列表中删除指定的元素
(defun MJ:removeNth (index lst / c)
  (setq c -1)
  (apply 'append
     (mapcar '(lambda (x)
            (if    (/= (setq c (1+ c)) index)
              (list x)
            )
          )
         lst
     )
  )
)
;;131.4 [功能] 从列表中删除指定的元素 By xianaihua
(defun RemoveNth6 (index lst / i)
  (setq i -1)
  (vl-remove-if '(lambda (x) (= (setq i (1+ i)) index)) lst)
)
;;131.5 [功能] 元素不在列表中，则加入之
;;(adjoin 0 '(1 2 3))->(0 1 2 3)
(defun adjoin (ele lst / tmp)
  (if (= (type lst) 'SYM)
    (setq tmp lst
      lst (eval tmp)
    )
  )
  (setq    lst (cond ((member ele lst) lst)
          (t (cons ele lst))
        )
  )
  (if tmp
    (set tmp lst)
    lst
  )
)
;;132 [功能] 关键字a的列表框增加内容
(defun MJ:mpoplst (a lst / n)
  (start_list a 3)
  (setq n 0)
  (repeat (length lst)
    (add_list (nth n lst))
    (setq n (+ n 1))
  )
  (end_list)
)
;;133.1 [功能] 旋转一个点(见113)
;;Rotate 'pnt'点 from a base point of 'p1' and through an angle 
;;of 'ang' (in radians)
(defun MJ:rotate_pnt (pnt p1 ang /)
  (polar p1 (+ (angle p1 pnt) ang) (distance p1 pnt))
)
;;133.2 [功能] 缩放一个点
;;scale 'pnt' from a base point of 'p1' by a factor of fact 
(defun MJ:scale_pnt (pnt p1 fact /)
  (polar p1 (angle p1 pnt) (* fact (distance p1 pnt)))
)
;;134.1 [功能] 返回文件名(带扩展名) (反findfile)
;;如a为"C:\\Program Files\\AutoCAD 2005\\support\\AlignObject.VLX",返回"AlignObject.VLX"
(defun MJ:pstrip (a / b)
  (cond    ((setq b (strsea "\\" a)) (setq b b))
    ((setq b (strsea "/" a)) (setq b b))
    (T (setq b (list 0)))
  )
  (setq a (substr a (+ (last b) 1) (strlen a)))
)
;;134.2 [功能] 去文件名扩展,比如去掉.exe
(defun MJ:xstrip (fna / st)
  (if (and (setq st (strsea "." fna))
       (<= (- (strlen fna) 3) (last st))
      )
    (setq fna (substr fna 1 (- (last st) 1)))
  )
  fna
)
(defun strsea (a b / c n)
  (cond    ((equal "" a) (setq c nil))
    ((not (equal (type b) (type "1")))
     (progn    (print "!!!!不是字符串!!!!")
        (print b)
        (setq c nil)
     )
    )
    (T
     (progn    (setq n 1)
        (while (>= (+ (- (strlen b) n) 1) (strlen a))
          (if (equal (substr b n (strlen a)) a)
            (setq c (append c (list n))
              n (- (+ n (strlen a)) 1)
            )
          )
          (setq n (+ n 1))
        )
     )
    )
  )
  c
)
;;134.3 [功能] 分割文件名为三部分
;;(fnsplitl "C:\\Program Files\\AutoCAD 2004\\acad.exe")
;;返回("C:\\Program Files\\AutoCAD 2004\\" "acad" ".exe")
;;135 [功能] p1是否在p2 p3线上
(defun what_side (p1 p2 p3 / a dx dx1 dy dy1)
  (setq    dx  (- (car p3) (car p2))
    dy  (- (cadr p3) (cadr p2))
    dx1 (- (car p1) (car p2))
    dy1 (- (cadr p1) (cadr p2))
  )
  (setq    a (- (* dx dy1) (* dy dx1))
    a (rtos a 2 6)
    a (atof a)
  )
  (if (not (equal 0.0 a))
    (setq a (/ a (abs a)))
  )
  a
)
;;136 [功能] 亮显选择集或对象(夹点不显示) 函数
(defun MJ:ayEntSSHighLight    (SSorEntName / oldGrips)
  (setq oldGrips (getvar "Grips"))
  (setvar "Grips" 0)
  (cond
    ((= (type SSorEntName) 'PICKSET)
     (sssetfirst nil SSorEntName)
    )
    ((= (type SSorEntName) 'ENAME)
     (sssetfirst nil (ssadd SSorEntName (ssadd)))
    )
  )
  (setvar "Grips" oldGrips)
)
;;137.1 [功能] 获得图形中倒数第二个图元的函数
(defun MJ:EntSecLast (/ e sle)
  (entdel (setq e (entlast)))
  (setq sle (entlast))
  (entdel e)
  sle
)
;;137.2 [功能] 图中最后图元Find True last entity
(Defun MJ:LASTENT (/ E0 EN)
  (Setq E0 (EntLast))
  (While (Setq EN (EntNext E0)) (Setq E0 EN))
  E0
)
;;138.1 [功能] 读取指定文件中指定行的内容
;;(MJ:getfile_text "test1.txt" 5)
(defun MJ:getfile_text (files line / fn text)
  (setq line(+ 1 line));本程序假定第一行为表头
  (setq files (findfile files))
  (if files
    (progn
      (setq fn(open files "r"))
      (if (<= line (MJ:getfile_line files))
        (progn
          (repeat line
            (setq text(read-line fn))
          )
          (close fn)
         text
        )
        nil
      )
    )
    nil
  )
)
;;138.2 [功能] 返回文件行数量
(defun MJ:getfile_line (files / tmplst x fn)
  (setq files (findfile files))
  (if files
    (progn
      (setq tmplst 0)
      (setq fn (open files "r"))
      (while (read-line fn)
    (setq tmplst (+ 1 tmplst))
      )
      (close fn)
      tmplst
    )
    nil
  )
)
;;138.3 [功能] 读取文件并按行将文件转换为表
;; 示例:(MJ:getfile "tyl.ini")
(defun MJ:getfile(files / tmplst x fn)
  (setq files(findfile files))
  (if files
    (progn
      (setq fn (open  files "r"))
      (while (setq x (read-line fn))
        (setq tmplst(append tmplst(list x)))
      )
      (close fn)
      tmplst
    )
     nil
  )
)
;;139 [功能] 用 [选择集/obj表] 做成一个组
(defun MJ:add-group (ss/objlst group_name / Group groups)
  (if (atom ss/objlst)
    (setq ss/objlst (mapcar 'vlax-ename->vla-object
       (MJ:SS->LIST ss/objlst)
      )
    )
  )
  (setq group (vla-add (vla-get-groups *doc*) group_name))
  (vlax-invoke group 'AppendItems ss/objlst)  group
)
;;140 [功能] 加载幻灯片
(defun MJ:loadsld (key sld / x y)
  (setq    x (dimx_tile key)
    y (dimy_tile key)
  )
  (start_image key)
  (fill_image 0 0 x y -2)
  (slide_image 0 0 x y sld)
  (end_image)
)
;;141 [功能] 点表排序
(defun Sort_XYZ_pList (PLIST / p1 p2)
  (setq    plist (vl-sort plist
               '(lambda    (p1 p2)
              (cond    ((< (car p1) (car p2)) T)
                ((and (= (car p1) (car p2))
                      (< (cadr p1) (cadr p2))
                 )
                 T
                )
                ((and (= (car p1) (car p2))
                      (= (cadr p1) (cadr p2))
                      (< (caddr p1) (caddr p2))
                 )
                 T
                )
                (T nil)
              )
            )
          )
  )
)
;;142 [功能] 选择集相减 By 自贡黄明儒2012.8.23
;;返回 选择集 or nil
;;(setq    ss1 (ssget)) (setq ss2 (ssget))
(defun SS_Sub    (SS1 SS2 / ENAME SS SSTEMP)
  (cond    ((and (equal (type ss1) 'PICKSET)
          (equal (type ss1) 'PICKSET)
     )
     (cond ((equal (sslength ss1) (sslength ss2))
        (vl-cmdf "_.select" ss1 "")
        (setq ss (ssget "p"))
        (vl-cmdf "_.select" ss2 "")
        (setq ssTemp (ssget "p"))
        (repeat    (sslength ssTemp)
          (Setq ENAME (SsName ssTemp 0))
          (SsDel ENAME ssTemp)
          (if (ssmemb ENAME ss)
            (SsDel ENAME SS)
          )
        )
        (if (equal (sslength ss) 0)
          nil
          ss
        )
           )
           (T
        (command "._Select" ss1 "_Remove" ss2 "")
        (ssget "_P")
           )
     )
    )
    ((and (equal (type ss1) 'PICKSET)
          (not (equal (type ss2) 'PICKSET))
     )
     ss1
    )
    (T nil)
  )
)
;;143.1 [功能]选择集SS排序->图元列表 By 自贡黄明儒 2012.8.28
;;注:选择集是按选择顺序排序,多选时按生成顺序排序,下面是按坐标排序
;;"D->U"从下到上;"U->D"从上到下;"L->R"从左到右;"R->L"从右到左
;;示例(setq ss (ssget)) (SS_Sort ss "D->U" "L->R")下到上,左到右
(defun SS_Sort_list (SS Sort1 Sort2 / E LST N PT10)
  ;;2.1 表 排序
  (defun Sort_pList (PLIST Sort1 Sort2 / SYMBOL1 SYMBOL2)
    (cond
      ((member Sort1 (list "L->R" "R->L"))
       (cond ((equal Sort1 "L->R") (setq Symbol1 '>))
         (T (setq Symbol1 '<))
       )
       (cond ((equal Sort2 "D->U") (setq Symbol2 '>))
         (T (setq Symbol2 '<))
       )
       (vl-sort
     PLIST
     '(lambda (p1 p2)
        (cond (((eval Symbol1) (car (car p1)) (car (car p2))) T)
          ((and    (= (car (car p1)) (car (car p2)))
            ((eval Symbol2) (cadr (car p1)) (cadr (car p2)))
           )
           T
          )
        )
      )
       )
      )
      (T
       (cond ((equal Sort1 "D->U") (setq Symbol1 '>))
         (T (setq Symbol1 '<))
       )
       (cond ((equal Sort2 "L->R") (setq Symbol2 '>))
         (T (setq Symbol2 '<))
       )
       (vl-sort
     PLIST
     '(lambda (p1 p2)
        (cond (((eval Symbol1) (cadr (car p1)) (cadr (car p2))) T)
          ((and    (= (cadr (car p1)) (cadr (car p2)))
            ((eval Symbol2) (car (car p1)) (car (car p2)))
           )
           T
          )
        )
      )
       )
      )
    )
  )
  ;;2.2 选择集SS排序 主程序
  (repeat (setq n (sslength ss))
    (setq e (ssname ss (setq n (1- n))))
    (setq pt10 (cdr (assoc 10 (entget e))))
    (setq lst (cons (cons pt10 e) lst))
  )
  (mapcar 'cdr (Sort_pList lst Sort1 Sort2))
)
;;143.2 [功能]选择集排序->选择集      By 自贡黄明儒 2012.8.28
(defun SS_Sort (SS Sort1 Sort2)
  (lst->ss (SS_Sort_list SS Sort1 Sort2))
)
;;144.1 [功能] 读取系统剪贴板中字符串
(defun GET-CLIP-STRING (/ HTML RESULT)
    (and (setq HTML (vlax-create-object "htmlfile"))
     (setq RESULT (vlax-invoke
              (vlax-get (vlax-get HTML 'PARENTWINDOW)
                    'CLIPBOARDDATA
              )
              'GETDATA
              "Text"
              )
     )
     (vlax-release-object HTML)
    )
    RESULT
)
;;144.2 [功能] 向系统剪贴板写入文字 
(defun SET-CLIP-STRING (STR / HTML RESULT)
    (and (= (type STR) 'STR)
     (setq HTML (vlax-create-object "htmlfile"))
     (setq RESULT (vlax-invoke
              (vlax-get (vlax-get HTML 'PARENTWINDOW)
                    'CLIPBOARDDATA
              )
              'SETDATA
              "Text"
              STR
              )
     )
     (vlax-release-object HTML)
    )
)
;;144.3 [功能] 清空剪贴板内文字
(defun xdl-clscliptext (/ ieobj)
  (setq
    ieobj (vlax-get-or-create-object "Internetexplorer.application")
  )
  (vlax-invoke ieobj 'navigate "about :blank") ;about与:blank间无空格
  (vlax-invoke
    (vlax-get (vlax-get (vlax-get ieobj 'document) 'parentwindow)
          'clipboarddata
    )
    'clearData
    "text"
  )
  (vlax-release-object ieobj)
)
;;145 [功能] 求多段线上的弧段(圆或圆弧也有效)的圆心
;;(getCenter (entsel "\n选择多段线弧段: "))
(defun getCenter (EP / E P)
  (mapcar 'set '(E P) EP)
  (setq P (apply 'vlax-curve-getClosestPointTo EP))
  (mapcar '+ P
             (vlax-curve-getsecondderiv
               E
               (vlax-curve-getParamAtPoint E P)
             )
  )
)
;;146 [功能] 质心
;;示例 (GetCentroid (car(entsel)))
(defun GetCentroid (poly / AXERR CEN PL REG VA)
  (setq    pl (*En2Obj* poly)
    va (vlax-make-safearray vlax-vbObject '(0 . 0))
  )
  (vlax-safearray-put-element va 0 pl)
  (setq axErr (VL-CATCH-ALL-APPLY 'vla-addregion (list *MS* va)))
  (if (VL-CATCH-ALL-ERROR-P axErr)
    nil
    (progn
      (setq reg    (car (vlax-safearray->list (vlax-variant-value axErr)))
        cen    (vla-get-centroid reg)
      )
      (vla-delete reg)
      (vlax-safearray->list (vlax-variant-value cen))
    )
  )
)
;;147.1 [功能] 自定义max
;;示例(max1 '("asd" "dfd" "hgrt"))返回"hgrt"
(defun max1 (lst)
  (if lst
    (if    (> (car lst) (max1 (cdr lst)))
      (car lst)
      (max1 (cdr lst)
      )
    )
  )
)
;;147.2 [功能] 自定义max
;;示例(max2 '("asd" "dfd" "hgrt"))返回"hgrt"
(defun max2 (l)
  (car (vl-sort l '>))
)
;;147.3 [功能] 自定义vl-remove-if
;; (remove-if 'numberp '(0 (0 1) "")) -> ((0 1) "")
(defun remove-if (pred from)
  (cond
    ((atom from) from)            ;nil or symbol (return that)
    ((apply pred (list (car from))) (remove-if pred (cdr from)))
    (t (cons (car from) (remove-if pred (cdr from))))
  )
)
;;147.4 [功能] 自定义remove-if-not
(defun remove-if-not (pred lst)        ; by Vladimir Nesterowsky
  (apply 'append
     (mapcar '(lambda (e)
            (if    (apply pred (list e))
              (list e)
            )
          )
         lst
     )
  )
)
;;147.5 [功能] 自定义vl-prin1-to-string
;; 1示例(symbol-name 'a) -> "a";(symbol-name a) -> nil
;; 2示例(symbol-name '(0 1 2 a)) -> "(0 1 2 A)"
(defun symbol-name (sym / f str tmp)
  ;; 执行完毕,搜索电脑,没有发现*sym.tmp
  ;; 下句产生临时文件的方法是不是与vl-filename-mktemp相同呢?
  (setq tmp "$sym.tmp");temp. filename, should be deleted原来创建txt文件如此简单!
  (setq f (open tmp "w"))
  (princ sym f)
  (close f)
  (setq    f   (open tmp "r")
    str (read-line f)
    f   (close f)
  )
  ;; (startapp "notepad" tmp);显示给使用者看
  str
)
;;148.1 [功能] 根据点表画多段线
(defun draw-pline1 (pts)
  (command "_PLINE")
  (mapcar 'command pts)
  (command "")
)
;;148.2 [功能] 根据点表画多段线
;; TF:T封闭，NIL不封闭
(defun draw-pline2 (pts tf)
  (apply 'command (cons "pline" pts))
  (if tf
    (command "c")
    (command "")
  )
)
;;148.3 [功能] 根据点表画多段线---xyp1964 
(defun Entmake-Spline (ptn / a)
  (entmake (append (list '(0 . "SPLINE")
                         '(100 . "AcDbEntity")
                         '(100 . "AcDbSpline")
                         '(71 . 3)
                   )
                   (mapcar '(lambda (pt) (cons 11 pt)) ptn)
           )
  )
  (entlast)
)
;;148.4 [功能] 根据点表画样条曲线
(defun draw-spline (pts)
  (command "_SPLINE")
  (mapcar 'command pts)
  (command "" "" "")
)
;;149.1 [功能] 进程显示
(defun spinner ()
  (if (not #spin)
    (setq #spin "-")
  )
  (cond
    ((equal #spin "-") (setq #spin "\\"))
    ((equal #spin "\\") (setq #spin "|"))
    ((equal #spin "|") (setq #spin "/"))
    (T (setq #spin "-"))
  )
  (princ (strcat (chr 8) #spin))
  (princ)                ;这句很重要
)
;;149.2 [功能] 进程显示
(defun HH:WORKING ()
  (if (= WRKCNT NIL)
    (setq WRKCNT 0)
  )
  (setq WRKCNT (1+ WRKCNT))
  (cond    ((= WRKCNT 1) (setq WRK "-"))
    ((= WRKCNT 2) (setq WRK "\\"))
    ((= WRKCNT 3) (setq WRK "|"))
    ((= WRKCNT 4) (progn (setq WRK "/") (setq WRKCNT 0)))
  )
  (princ (strcat "\n* " WRK " 请稍候...... ! " WRK " *"))
  (princ)
)
;;149.3 [功能] 进程显示
(defun spin (wh)
    (princ (strcat "\r  "
            wh
            (cond ((= #spin "|") (setq #spin "/"))
              ((= #spin "/") (setq #spin "-"))
              ((= #spin "-") (setq #spin "\\"))
              (T (setq #spin "|"))
            )
        )
    )
    (princ)
  )
;;150 [功能] 生成无名组
;;示例(bns_makgrp (MJ:SS->LIST (ssget)) "描述")
(defun bns_makgrp (LST DESC / EN)
  (command "_.-group" "_create" "*" DESC)
  (foreach EN LST (command EN))
  (command "")
)
;;151 [功能] 曲线选集长度求和--陌生人.2004.1
;;示例(MJ:lens nil)
(defun MJ:lens (ss / ss ssv lens)
  (if (= nil ss)
    (setq ss (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))
  )
  (setq    ssv  (vla-get-activeselectionset
           (vla-get-activedocument (vlax-get-acad-object))
         )
    lens 0
  )
  (vlax-for obj    ssv
    (setq lens (+ lens
          (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj))
           )
    )
  )
)
;;152.1 [功能] 局部重生 by Lee Mac
;;示例 (MJ:Update (entget (car (entsel))))
(defun MJ:Update (enlist)
  (entupd (cdr (assoc -1 enlist)))
)
;;152.2 [功能] 局部重生
;;示例(MJ:RedrawSS (ssget))
(defun MJ:RedrawSS (ss)
  (
   (lambda (i)
     (while (setq e (ssname ss (setq i (1+ i))))
       (entupd e)
     )
   )
    -1
  )  
)
;;153.1 [功能] 注册应用程序名的选择集
(defun ssget-app (rname)
  (ssget "X" (list (list -3 (list rname))))
)
;;153.2 [功能] 一个图元的扩展数据列表
;;示例 (get-eedlist-all (car (entsel)))
(defun get-eedlist-all (ent)
  (cdadr (assoc -3 (entget ent) '("*"))))
)
;;153.3 [功能] 一个图元的扩展数据列表(无注册应用程序名)
(defun getxdata-all (e apnlst)
  (apply 'append (mapcar 'cdr (getxdata e apnlst)))
)
;;153.4 [功能] 一个图元的扩展数据列表
(defun getxdata    (e apnlst)
  (cdr (assoc -3 (entget e apnlst)))
)
;;153.5 [功能] 删除扩展数据
(defun DelXdata    (eName )
  (entmod
    (list
      (cons -1 eName)
      (cons -3
        (mapcar 'list
            (mapcar 'car (cdr (assoc -3 (entget eName '("*")))))
        )
      )
    )
  )
)
;;153.6 [功能] 附着扩展图元数据到AutoCAD对象上
;; 示例(ax:PutXData myVlaObj '((1001 . "ACADX") (1000 . "myStringData")))
(defun ax:PutXData (vlaObj XData)
  (setq XData
         (ax:BuildFilter
           (mapcar
             '(lambda (item / key)
                (setq key (car item))
                (if (<= 1010 key 1033)
                  (cons key
                        (vlax-variant-value
                          (vlax-3d-point
                            (cdr item)
                          )
                        )
                  )
    item
                )
              )
             XData
           )
         )
  )
  (vla-setXData vlaObj (car XData) (cadr XData))
)
;;153.7 [功能] 设置链接在一个实体上，或者获取链接(geturl)--Highflybird
(defun c:PutHyperlink1 (/ e)
  (if (setq e (car (entsel "\nSelect Object to Add Hyperlink to: ")))
    (seturl e "http://www.google.co.uk")
  )
  (princ)
)
(defun c:PutHyperlink2 (/ e)
  (if (setq e (car (entsel "\nSelect Object to Add Hyperlink to: ")))
    (vla-add (vla-get-hyperlinks (vlax-ename->vla-object e))
             "http://www.google.co.uk"
    )
  )
  (princ)
)
;;154.1 [功能] 获取ObjectDBX版本字符串
;;用于操作非打开文件
(defun GetObjectDBXVer (/ VERSION)
  (if (>= (setq VERSION (atoi (getvar "acadver"))) 16)
    (strcat "ObjectDBX.AxDbDocument." (itoa VERSION))
  )
)
;;154.2 [功能] dwg转dxf文件函数
;;非打开文件
(defun Dwg2Dxf (DwgName dxfName / dbxDoc)
  (setq    dbxDoc (vla-GetInterfaceObject
         (vlax-get-acad-object)
         (GetObjectDBXVer)
           )
  )
  (vla-open dbxDoc DwgName)        ;不能打开.dxf文件
  ;;(vla-import dbxDoc DwgName InsertPoint scalefactor);是不行的.
  (vlax-invoke dbxDoc "dxfout" dxfName)
  (if dbxDoc
    (vlax-release-object dbxDoc)
  )                    ;关闭文档,用(vla-close dbxDoc :vlax-false)行不通?
)
;;154.3 [功能] 将文件存为2K格式，并去教育版(文件名不变)
;;非打开的文件
;;(DwgOut "D:\\Drawing1.dwg")
(defun DwgOut (DwgName / BACKUPFILE BASENAME DOCOBJ DXFFILE FILEPATH)
  ;;1 获取全路径，即路径后有
  (defun GetFullPath (path)
    (if    (wcmatch path "*\\")
      path
      (strcat path "\\")
    )
  )
  ;;2 能删除所有文件，不管只读、隐藏与否，都能删除  
  (defun DeleteFile (FIL / FILSYS FILDIR SS ENT)
    (setq FILSYS (vlax-create-object "Scripting.FileSystemObject"))
    (setq FILDIR (vl-filename-directory FIL))
    (setq
      SS (vl-directory-files
       FILDIR
       (strcat (vl-filename-base FIL) (vl-filename-extension FIL))
       1
     )
    )
    (foreach ENT SS
      (vlax-invoke
    FILSYS
    "deletefile"
    (strcat FILDIR "\\" ENT)
    :vlax-false
      )
    )
    (vlax-release-object FILSYS)
  )
  ;;3 本程序主程序:1转成dxf 2原文件改名为备份 3打开另存为2K 4删除dxf
  (setq    BaseName   (vl-filename-base DwgName)
    filepath   (vl-filename-directory DwgName)
    dxfFile       (vl-string-subst ".dxf" ".dwg" DwgName)
    BackupFile (strcat (getfullpath filepath)
               BaseName
               "_Backup"
               (vl-filename-extension DwgName)
           )
  )
  (Dwg2Dxf DwgName dxfFile)        ;利用objectdbx转存文件,目的是去教育版印戳
  (if (findfile BackupFile)
    (deletefile BackupFile)
  )                    ;检查原dwg文件的备份文件名是否存在，如果存在，则删除
  (if (vl-file-rename DwgName BackupFile) ;修改原dwg文件名
    (progn
      (setq
    DocObj (vla-open (vla-get-documents (vlax-get-acad-object))
             dxfFile
           )
      )                    ;打开dxf文件
      (vla-saveas DocObj DwgName acR15_DWG) ;再存为2k版dwg文件
      (vla-close DocObj :vlax-false)
      (deletefile dxfFile)        ;删除dxf文件
    )
  )
  (princ)
)
;;154.4 [功能] 将文件以Wblock输出,并去教育版(文件名不变)
;;非打开的文件
;;示例 (DwgOutWblock "D:\\Drawing1.dwg")
(defun DwgOutWblock
            (DwgName    /       BACKUPFILE BASENAME
             DOCOBJ    DXFFILE       FILEPATH   NEWSET
             SSETS
            )
  ;;1 获取全路径，即路径后有
  (defun GetFullPath (path)
    (if    (wcmatch path "*\\")
      path
      (strcat path "\\")
    )
  )
  ;;2 能删除所有文件，不管只读、隐藏与否，都能删除  
  (defun DeleteFile (FIL / FILSYS FILDIR SS ENT)
    (setq FILSYS (vlax-create-object "Scripting.FileSystemObject"))
    (setq FILDIR (vl-filename-directory FIL))
    (setq
      SS (vl-directory-files
       FILDIR
       (strcat (vl-filename-base FIL) (vl-filename-extension FIL))
       1
     )
    )
    (foreach ENT SS
      (vlax-invoke
    FILSYS
    "deletefile"
    (strcat FILDIR "\\" ENT)
    :vlax-false
      )
    )
    (vlax-release-object FILSYS)
  )
  ;;3 本程序主程序:1转成dxf 2原文件改名为备份 3打开并以wblock输出 4删除dxf
  (setq    BaseName   (vl-filename-base DwgName)
    filepath   (vl-filename-directory DwgName)
    dxfFile       (vl-string-subst ".dxf" ".dwg" DwgName)
    BackupFile (strcat (getfullpath filepath)
               BaseName
               "_Backup"
               (vl-filename-extension DwgName)
           )
  )
  (Dwg2Dxf DwgName dxfFile)        ;利用objectdbx转存文件,目的是去教育版印戳
  (if (findfile BackupFile)
    (deletefile BackupFile)
  )                    ;检查原dwg文件的备份文件名是否存在，如果存在，则删除
  (if (vl-file-rename DwgName BackupFile) ;修改原dwg文件名
    (progn
      (setq
    DocObj (vla-open (vla-get-documents (vlax-get-acad-object))
             dxfFile
           )
      )                    ;打开dxf文件
      (setq ssets (vla-get-selectionsets DocObj))
      (if (vl-catch-all-error-p
        (vl-catch-all-apply 'vla-item (list ssets "$Set"))
      )
    (setq newSet (vla-add ssets "$Set"))
    (progn
      (vla-delete (vla-item ssets "$Set"))
      (setq newSet (vla-add ssets "$Set"))
    )
      )
      ;;select all objects in the drawing
      (vla-Select newSet acSelectionSetAll)
      (vla-WBlock DocObj DwgName newSet)
      (vla-close DocObj :vlax-false)
      (deletefile dxfFile)        ;删除dxf文件
    )
  )
  (princ)
)
;;154.5 [功能] 打开的文件以Wblock输出,并去教育版(除激活的文档外,文件名不变)
(defun DwgOutWblockOpen    (/ *ACAD* *DOCS* BASENAME CUR DWGNAME DWGNAMEEXT DWGNAMELIST FILEPATH N NEWDWGNAME SSOBJ)
  ;;1 获取全路径，即路径后有
  (defun GetFullPath (path)
    (if    (wcmatch path "*\\")
      path
      (strcat path "\\")
    )
  )
  (setq    *ACAD* (vlax-get-acad-object)
    *DOCS* (vla-get-Documents *ACAD*)
  )
  ;;2 打开的文件(除激活的文档外),全关闭,按非打开处理,再打开
  ;;DwgNameList除激活的文档外的打开文件列表,并关闭
  (vlax-for item *DOCS*
    (if    (= (vla-get-active item) :vlax-false)
      (progn (setq DwgName (vlax-get-property item 'FullName))
         (setq DwgNameList (cons DwgName DwgNameList))
         (vla-close item :vlax-false)
      )
      (setq cur item)
    )
  )
  (setq n -1)
  (repeat (length DwgNameList)
    (setq DwgName (nth (setq n (1+ n)) DwgNameList))
    (DwgOutWblock DwgName)
    (vla-open (vla-get-documents (vlax-get-acad-object)) DwgName)                    ;再打开
  )
  ;;3 激活的文档须更名输出
  (setq DwgName (vlax-get-property cur 'FullName))
  (setq BaseName (vl-filename-base DwgName))
  (setq filepath (vl-filename-directory DwgName))
  (setq DwgNameExt (vl-filename-extension DwgName))
  (setq n -1)
  (while (findfile (setq NewDwgName
              (strcat (getfullpath filepath)
                  BaseName
                  (itoa (setq n (1+ n)))
                  DwgNameExt
              )
           )
     )
  )
  (ssget "x" (list (cons 410 (getvar "ctab"))))
  (setq SSOBJ (vla-get-activeselectionset cur))
  (vla-wblock cur NewDwgName SSOBJ)
  (DwgOutWblock NewDwgName)
  (vla-open (vla-get-documents (vlax-get-acad-object)) NewDwgName)
  (alert (strcat "\n 当前文档已经更名为" BaseName (itoa n)))
  (command "vbastmt" "AcadApplication.activeDocument.close false ")
)
;;154.6 [功能] 打开的文件全部Wblock输出
(defun OpenFileWblock (/ *ACAD* *DOCS* BASENAME DWGNAME DWGNAMEEXT EACH FILEPATH N NEWDWGNAME NEWSET SSETS J)
  ;;1 获取全路径，即路径后有
  (defun GetFullPath (path)
    (if    (wcmatch path "*\\")
      path
      (strcat path "\\")
    )
  )
  ;;2 打开的文件更名输出
  (setq *acad* (vlax-get-acad-object))
  (setq *DOCS* (vla-get-Documents *ACAD*))
  (setq n -1)
  (repeat (vlax-get-Property *DOCS* 'count)
    (setq each (vla-item *docs* (setq n (1+ n))))
    (setq DwgName (vlax-get-Property each 'fullname))
    (setq BaseName   (vl-filename-base DwgName)
      filepath   (vl-filename-directory DwgName)
      DwgNameExt (vl-filename-extension DwgName)
    )
    (setq J -1)
    (while (findfile (setq NewDwgName
                (strcat (getfullpath filepath)
                    BaseName
                    (itoa (setq J (1+ J)))
                    DwgNameExt
                )
             )
       )
    )
    (setq ssets (vla-get-selectionsets each))
    (if    (vl-catch-all-error-p
      (vl-catch-all-apply 'vla-item (list ssets "$Set"))
    )
      (setq newSet (vla-add ssets "$Set"))
      (progn
    (vla-delete (vla-item ssets "$Set"))
    (setq newSet (vla-add ssets "$Set"))
      )
    )
    ;;select all objects in the drawing
    (vla-Select newSet acSelectionSetAll)
    (vla-WBlock each NewDwgName newSet)
  )
  (princ)
)
;;154.7 [功能] 复制非打开文件的块至本图
;;(Odbx-copyblocks 文件名)
;;(Odbx-copyblocks "D:\\DrawingA.dwg"),之后输入命令i,就可以看到DrawingA的块均在本图中了
(defun Odbx-copyblocks (DwgName / DBXBLOCKS DBXDOC NUM)
  (setq    dbxDoc (vla-GetInterfaceObject
         (vlax-get-acad-object)
         (GetObjectDBXVer)
           )
  )
  (vla-open dbxDoc DwgName)        ;不能打开.dxf文件,返回nil
  (setq DBXBLOCKS (vla-get-blocks dbxDoc))
  (vlax-for BLK    DBXBLOCKS
    (if    (and (not (wcmatch (substr (vla-get-name BLK) 1 1) "`*"))
         (= (vla-get-isxref BLK) :vlax-false)
    )                ;去除系统块、匿名块和参照类对象
      (setq namelst (append namelst (list (vla-get-name BLK))))
    )
  )
  (foreach name    namelst
    (setq num (vla-item DBXBLOCKS name))
    (vla-copyobjects
      dbxDoc
      (vlax-safearray-fill
    (vlax-make-safearray vlax-vbobject '(0 . 0))
    (list num)
      )
      (vla-get-modelspace
    (vla-get-activedocument (vlax-get-acad-object))
      )
    )
  )
  (if dbxDoc
    (vlax-release-object dbxDoc)
  )
)
;;154.8 [功能] 复制非打开文件的特定块至本图
;;示例(CopyBlock "D:\\DrawingA.dwg" "ccd1"),之后输入命令i,就可以看到DrawingA的"ccd1"块在本图中了
;; COPYBLOCK.LSP  Copyright ?999  Tony Tanzillo
;;   http://www.caddzone.com
;;   tony.tanzillo@caddzone.com
(defun CopyBlock (DwgName BlkName / *ACAD* BLOCKS DBXDOC NUM)
  (setq *acad* (vlax-get-acad-object))
  (setq blocks (vla-get-blocks (vla-get-ActiveDocument *acad*)))
  (setq dbxDoc (vla-GetInterfaceObject *acad* (GetObjectDBXVer)))
  (vla-open dbxDoc DwgName)
  (setq num (vla-item (vla-get-blocks dbxDoc) BlkName))
  (vla-CopyObjects
    dbxDoc
    (vlax-safearray-fill
      (vlax-make-safearray
    vlax-vbObject
    '(0 . 0)
      )
      (list num)
    )
    blocks
  )
  (vlax-release-object dbxDoc)
  (vla-item blocks BlkName)
)
;;154.9 [功能] 复制特定文件的块至本图(不论打开或者非打开)
;;本程序将选择一个文件,然后将其下的块均拷贝到本图中,用命令i就可以插入这些块了
(defun B2CurDrawing (/ *ACAD* *DOC* *DOCS* FNAME FULLNAME LST)
  (defun Open-copyblocks (fname / BLOCKS DOC DOCBLOCKS NAMELST NUM)
    (setq blocks (vla-get-blocks *DOC*))
    (setq Doc (vla-item    *DOCS*
            (strcat    (vl-filename-base fname)
                (vl-filename-extension fname)
            )
          )
    )
    (setq DocBLOCKS (vla-get-blocks Doc))
    (vlax-for BLK DocBLOCKS
      (if (and (not (wcmatch (substr (vla-get-name BLK) 1 1) "`*"))
           (= (vla-get-isxref BLK) :vlax-false)
      )                ;去除系统块、匿名块和参照类对象
    (setq namelst (append namelst (list (vla-get-name BLK))))
      )
    )
    (foreach name namelst
      (setq num (vla-item DocBLOCKS name))
      (vla-CopyObjects
    Doc
    (vlax-safearray-fill
      (vlax-make-safearray
        vlax-vbObject
        '(0 . 0)
      )
      (list num)
    )
    blocks
      )
    )
    (vlax-release-object doc)
  )
  (setq    *ACAD* (vlax-get-acad-object)
    *DOC*  (vla-get-ActiveDocument *acad*)
    *DOCS* (vla-get-Documents *ACAD*)
  )
  ;;(setq fullname (vla-get-fullname *DOC*))
  ;;打开文件列表
  (vlax-for doc    *DOCS*
    (setq
      lst (cons    (if (/= (setq fname (vla-get-fullname doc)) "")
          fname
          (vla-get-name doc)
        )
        lst
      )
    )
  )
  (setq    fname (getfiled    "选择DWG文件"
            (getvar "DWGPREFIX")
            "DWG"
            0
          )
  )
  ;;(VL-FILE-SYSTIME fname);打开的文件返回nil,这个方法太好了
  ;;(vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list *DOCS* fname)))
  (cond    ((and fname (member fname lst) (not (equal fullname fname)))
     (Open-copyblocks fname)
    )
    ((and fname (not (member fname lst)))
     (Odbx-copyblocks fname)
    )
    (T nil)
  )
  (princ)
)
;;155 [功能] 统计组定义个数--lxx.2004.2
(defun c:countgp ()
  (vla-get-count (vla-get-groups (vla-get-activedocument(vlax-get-acad-object))))
)
;;155.1.1 [功能] 炸开所有组
(defun c:delgps ()
  (vlax-for obj (vla-get-groups (vla-get-activedocument(vlax-get-acad-object)))
    (vla-delete obj)
  )
)
;;155.1.2 [功能] 分解组
(defun bns_groups_unsel    (/ na e1 a n lst lst2 lst3)
  (defun m_assoc (a lst / b lst2)
    (while (setq b (assoc a lst))
      (setq lst     (cdr (member b lst))
        lst2 (append lst2 (list b))
      )
    )
    lst2
  )
  (setq lst (dictsearch (namedobjdict) "ACAD_GROUP"))
  (setq lst2 (m_assoc 3 lst))  
  (repeat (setq n (length lst2))
    (setq a (nth (setq n (1- n )) lst2))
    (setq na (cdr (car (cdr (member a lst)))))
    (setq e1 (entget na))
    (if    (member '(71 . 1) e1)
      (progn
    ;;(command "_.-group" "_sel" (cdr a) "_y")
    (setq e1 (subst '(71 . 0) '(71 . 1) e1))
    (entmod e1)
    (setq lst3 (append lst3 (list na)))
      )
    )    
  )
  lst3
)
;;155.1.3 [功能] 重组分解组
;;(setq lst (bns_groups_unsel))(bns_groups_sel lst)
(defun bns_groups_sel (lst / n na e1)  
  (repeat (setq n (length lst))
    (setq na (nth (setq n (1- n)) lst)
      e1 (entget na)
    )
    (setq e1 (subst '(71 . 1) '(71 . 0) e1))
    (entmod e1)
  )
)
;;155.1.4 删除匿名组(并不删除组对象) lxx.2005.10.
(defun c:del*gp ()
  (vlax-for obj (vla-get-groups (vla-get-activedocument(vlax-get-acad-object)))
    (if (wcmatch (vla-get-name obj)"'**")(vla-delete obj))
  )
)
;;155.1.5 [功能] 删除空组及数量为1的组定义(并不删除组对象) By lxx.2005.10改.
(defun c:delgp0 ()
  (vlax-for obj (vla-get-groups (vla-get-activedocument(vlax-get-acad-object)))
    (if (< (vla-get-count obj)2)(vla-delete obj))
  )
)
;;155.2 [功能] 组定义添加实体.
(defun GroupAdd    (/ B G)
  (if (and (setq g (car (entsel "\n 击要添加对象的组：")))
       (setq b (cons 340 (car (entsel "\n 添加到组的对象："))))
      )
    (progn (setq g (gpdef1 G))
       (entmod (append g (list b)))
    )
  )
  (princ)
)
;;155.3.1 [功能] 所有组列表
(defun c:listgps ()
  (vlax-for obj    (vla-get-groups
          (vla-get-activedocument (vlax-get-acad-object))
        )
    ;;(setq gphd (append gphd (list (vla-get-handle obj))))
    (print (entget (handent (vla-get-handle obj))))
  )
  ;;(mapcar '(lambda (x) (print (entget (handent x))) (print)) gphd)
  (princ)
)
;;155.3.2 [功能] 所有可选择的组名列表
;;组可选标志: dxf70 =3?
(defun c:gpsel1 (/ gps)
  (vlax-for obj    (vla-get-groups
          (vla-get-activedocument (vlax-get-acad-object))
        )
    (if    ;;(/= 3 (cdr (assoc 70 (entget (vlax-vla-object->ename obj)))))
    (/= 3
        (cdr (assoc 70 (entget (handent (vla-get-handle obj)))))
    )
      (setq gps (append gps (list (vla-get-name obj))))
    )
  )
  gps
)
;;155.3.3 [功能] 求所有组名列表
(defun c:gpsel2 (/ LST)
  (setq lst (dictsearch (namedobjdict) "ACAD_GROUP"))
  (mapcar 'cdr
      (vl-remove-if '(lambda (x) (/= 3 (car x))) lst)
  )
)  
;;155.4.1 [功能] 求组定义(一重的组)
;;测试: (gpdef1 (car(entsel)))
(defun gpdef1 (gpe)
  (entget(cdr(assoc 330 (entget gpe))))
)
;;155.4.2 [功能] 求组内实体(一重的组)
;;测试:返回-> (<图元名: 7ef7ceb0> <图元名: 7ef7ceb8> <图元名: 7ef7cea8>) 
(defun C:GetGroupEntity ()
  (mapcar 'cdr
      (vl-remove-if
        '(lambda (x) (/= 340 (car x)))
        (gpdef1 (car (entsel)))
      )
  )
)
;;155.4.3 [功能] 求组名(一重的组)
(defun C:GroupName1 (/ GPDEFL GPDICT GPNAME)
  (setq gpdefl (gpdef1 (car (entsel))))
  (setq gpdict (entget (cdr (assoc 330 gpdefl))))
  (setq    gpname (cdadr (member (cons 350 (cdr (assoc -1 gpdefl)))
                  (reverse gpdict)
              )
           )
  )
)
;;155.5.1 [功能] 求组定义列表 -> (组定义1 组定义2 ...):
;;测试: (gpdef (car(entsel)))
(defun gpdef (gpe / el lst a gpdf gplst)
  (setq el (entget gpe))
  (if (setq lst (member '(102 . "{ACAD_REACTORS") el))
    (while (and (setq lst (cdr lst)) (= 330 (car (setq a (car lst)))))
      (if (= "GROUP" (cdr (assoc 0 (setq gpdf (entget (cdr a))))))
    (setq gplst (cons gpdf gplst))
      )
    )
  )
  (reverse gplst)
)  
;;155.5.2 [功能] 求组内实体: 求组信息-----lxx.2004.5
;;示例:(getgp (car(entsel)))=>(("G3" <Entity name: 7ef7bd90> (<Entity name: 7ef7b500> <Entity name: 7ef7b378>)) ("G4" <Entity name: 7ef7bd98> (<Entity name: 7ef7b500><Entity name: 7ef7b378> <Entity name: 7ef7acd0>)))
(defun getgp (gpe / GPDICT GPELST GPENT GPNAME X)
  (mapcar '(lambda (x)
         (setq gpent  (cdr (assoc -1 x))
           gpelst (mapcar 'cdr
                  (vl-remove-if '(lambda (x) (/= 340 (car x))) x)
              )
           gpdict (entget (cdr (assoc 330 x)))
           gpname (cdadr (member (cons 350 gpent) (reverse gpdict)))
         )
         (list gpname gpent gpelst)
       )
      (gpdef gpe)
  )
)
;;155.5.3 [功能] 取得组名列表:
;; (gpn1 (car(entsel))) -> ("X1" "X2" "TT")
(defun gpn1 (gpe / el lst a gpdf gps gpname gpnlst)
  (setq el (entget gpe))
  (if (setq lst (member '(102 . "{ACAD_REACTORS") el))
    (while (and (setq lst (cdr lst)) (= 330 (car (setq a (car lst)))))
      (if (= "GROUP" (cdr (assoc 0 (setq gpdf (entget (cdr a))))))
    (setq gps    (if gps
               gps
               (entget (cdr (assoc 330 gpdf)))
             )
          gpname (cdadr (member (cons 350 (cdr (assoc -1 gpdf)))
                    (reverse gps)
                )
             )
          gpnlst (cons gpname gpnlst)
    )
      )
    )
  )
  (reverse gpnlst)
)
;;155.5.4 [功能] 取得组名列表:
;; (gpn2 (car(entsel))) -> ("X1" "X2" "TT")
(defun gpn2 (gpe / el lst a g gpnlst)  
  (setq el (entget gpe))
  (if (setq lst (member '(102 . "{ACAD_REACTORS") el))
    (while (and (setq lst (cdr lst)) (= 330 (car (setq a (car lst)))))
      (if (= "GROUP" (cdr (assoc 0 (entget (setq g (cdr a))))))
    ;;(= "AcDbGroup"  (vla-get-objectName (setq gobj (vlax-ename->vla-object (cdr a)))))
    (setq gpnlst (cons (vla-get-Name (vlax-ename->vla-object g)) gpnlst))
      )
    )
  )
  (reverse gpnlst)
)
;;155.5.5 [功能] 取得组名列表:
(defun gpn3 (/ doc theobj grp obj kj ip)  
  (setq doc (vla-get-Activedocument (vlax-get-acad-object)))
  (vla-getentity
    (vla-get-utility doc)
    'theobj
    'ip
    "\nSelect Object: "
  )
  (vlax-for grp    (vla-get-groups doc)
    (vlax-for obj grp
      (if (equal (vla-get-objectid obj) (vla-get-objectid theobj))
    (setq kj (cons (vla-get-name grp) kj))
      )
    )
  )
  kj
)
;;155.5.6 [功能] 取得组名列表:
;;(gpn4 (car(entsel)))
(defun gpn4 (e / g)
  ;;获取实体的永久反应器 --- by eachy
  ;;(get_object_reactor (car(entsel))),同(acet-acadreactor-ids-get (car (entsel)))-by lucas
  (defun get_object_reactor (e / elst lst etlst)
    (setq elst (entget e))
    (if    (and (assoc 102 elst)
         (= (cdr (assoc 102 elst)) "{ACAD_REACTORS")
    )
      (progn
    (setq lst (cdr (member '(102 . "{ACAD_REACTORS") elst)))
    (while (= (caar lst) 330)
      (setq etlst (cons (cdar lst) etlst))
      (setq lst (cdr lst))
    )
      )
    )
    etlst
  )
  (setq lst (get_object_reactor e))
  (foreach item    (mapcar 'vlax-ename->vla-object lst)
    (if    (= (vla-get-objectname item) "AcDbGroup")
      (setq g (cons (vla-get-name item) g))
    )
  )
  g
)
;;155.5.7 [功能] 取得组名列表: --by 灯火
;;(gpn5 (car(entsel)))
(defun gpn5 (eName / DXF102 ELIST EN ET GPNAME OBJGROPU)
  (setq dxf102 (assoc 102 (entget eName)))
  (if (and dxf102 (= (cdr dxf102) "{ACAD_REACTORS"))
    (progn
      (setq
    eList (cdr (member '(102 . "{ACAD_REACTORS") (entget eName)))
      )
      (while (= (caar eList) 330)
    (setq en (cdar eList))
    (setq et (cdr (assoc 0 (entget en))))
    (if (= et "GROUP")
      (progn
        (setq objGropu (vlax-ename->vla-object en))
        (setq gpName (cons (vla-get-Name objGropu) gpName))
      )
    )
    (setq eList (cdr eList))
      )
    )
  )
  gpName
)
;;155.5.8 [功能] 取得组名列表: --by 灯火
;;(gpn6 (car(entsel)))
(defun gpn6 (ename / key dct rtn)
  (setq    key (cons 340 ename)
    dct (dictsearch (namedobjdict) "acad_group")
  )
  (while (setq dct (member (assoc 3 dct) dct))
    (if    (member key (entget (cdadr dct)))
      (setq rtn (cons (cdar dct) rtn))
    )
    (setq dct (cddr dct))
  )
  (reverse rtn)
)
;;155.5.9 [功能] 取得组名列表: --by 灯火
;;(gpn7 (car(entsel)))
(defun gpn7 (Obj / Cur_ID NmeLst)
  (setq    Gb:AcO (cond (Gb:AcO)
             (T (vlax-get-acad-object))
           )
    Gb:AcD (cond (Gb:AcD)
             (T (vla-get-activedocument Gb:AcO))
           )
    Cur_ID (vla-get-ObjectID (vlax-ename->vla-object Obj))
  )
  (vlax-for Grp    (vla-get-Groups Gb:AcD)
    (vlax-for Ent Grp
      (if (equal (vla-get-ObjectID Ent) Cur_ID)
    (setq NmeLst (cons (vla-get-Name Grp) NmeLst))
      )
    )
  )
  (reverse NmeLst)
)
;;155.6. [功能] 生成无名组
;;示例(acet-group-make-anon (list WIPOUT TXT) "In use by TEXTMASK")
(defun acet-group-make-anon (LST DESC / EN)
  (command "_.-group" "_create" "*" DESC)
  (foreach EN LST (command EN))
  (command "")
)
;;156.1 [功能] 删除重叠对象(overkill)
;;不知谁写的,太好了.
(DEFUN HH:delBLOCKs (ss / E EN K LIST1 S9 XY)
  (repeat (setq k (sslength ss))
    (if    (and (setq e (ssname ss (setq k (1- k))))
         (setq en (entget e))
    )
      (progn
    (setq xy (cdr en))
    (IF (SETQ S9 (ASSOC 5 XY))
      (SETQ XY (subst '(5 . "ASD") S9 XY))
    )
    (if (member xy list1)
      (entdel e)
      (setq list1 (cons xy list1))
    )
      )
    )
  )
)
;;156.2 [功能] 删除重叠数字，保留较大的数或保留较小的数---Gu_xl 
(defun c:delWords (/ kd e ll ur n s1 L SS)
  (initget "Big Small")
  (setq kd (getkword "\n[留大数Big/留小数Small]<Big>:"))
  (if (= "Small" kd)
    (setq kd <)
    (setq kd >)
  )
  (while (setq ss (ssget ":S" '((0 . "*text"))))
    (while (> (sslength ss) 0)
      (setq e (ssname ss 0))
      (vla-GetBoundingBox (vlax-ename->vla-object e) 'll 'ur)
      (setq ll (vlax-safearray->list ll)
        ur (vlax-safearray->list ur)
      )
      (setq s1 (ssget "c"
              (trans ll 0 1)
              (trans ur 0 1)
              '((0 . "*text"))
           )
        l  nil
      )
      (repeat (setq n (sslength s1))
    (setq l (cons (ssname s1 (setq n (1- n))) l))
      )
      (setq l (vl-sort l
               '(lambda    (a b)
              (kd (atof (cdr (assoc 1 (entget a))))
                  (atof (cdr (assoc 1 (entget b))))
              )
            )
          )
      )
      (ssdel (car l) ss)
      (foreach a (cdr l)
    (ssdel a ss)
    (entdel a)
      )
    )
  )
  (princ)
)
;;157 [功能] 曲线取点函数(用于封闭曲线内局部放大或者删除其内图元时)
;;示例(ssget "WP" (Object-Plst (car (entsel))) '((0 . "*TEXT,DIMENSION")))
(defun Object-Plst (EntCicl / END I LEN LINEOBJ NUM PLST PT START)
  (setq    lineObj    (vlax-ename->vla-object EntCicl)
    start    (vlax-curve-getStartParam lineObj)
    end    (vlax-curve-getEndParam lineObj)
  )
  (setq    num 100                ;取100点
    i -1
  )
  (setq len (/ (- end start) num))
  (while (< i num)
    (setq i (1+ i))
    (setq pt (vlax-curve-getPointAtParam lineObj (* i len)))
    (setq plst (append plst (list pt)))
  )
  plst
)
;;158 [功能] ENTSEL函数功能扩展 caoyin
;;  MSG：和ENTSEL一样，为用于提示用户的字符串，当该参数为nil时，缺省提示信息为“选择对象: ”。
;;  FIL：图元dxf特性过滤器，和ssget函数相同。
;;  ERRMAG：出错提示信息，在选择目标不符合条件时在命令行打印。当该参数为nil时，缺省提示信息为"无效的对象。"。
(defun MC:ENTSEL1 (MSG FIL ERRMSG / E PF SS RT ERR)
  (setq    E  T
    PF (getvar 'PICKFIRST)
  )
  (or ERRMSG (setq ERRMSG "无效的对象。"))
  (setvar 'PICKFIRST 1)
  (while E
    ;;用apply的目的在于当entsel后面的参数为nil时不会出错。
    (if    (setq E (apply 'entsel (cond (MSG (list MSG)))))
      (cond
    ((vl-consp E)
     ;;后面的ssadd是建立一个空选择集，前面的ssadd是向该空选择集中添加entsel所拾取的图元。
     (setq SS (ssadd (car E) (ssadd)))
     ;;将选择集SS设为已选择状态
     (sssetfirst nil SS)
     (setvar "nomutt" 1)
     ;;获取当前激活的选择集，而过滤器则保证从中筛选出符合条件的对象。
     (if (setq SS (ssget "_I" FIL))
       ;;当SS返回为真，则将变量E设为nil以结束while，反之则打印出错提示信息，并将变量E设为T以确保while继续执行。
       (setq RT E
         E  nil
       )
       (progn (princ ERRMSG) (setq E T))
     )
     (setvar "nomutt" 0)
    )
    (T
     (setq RT E
           E  nil
     )
    )
      )
      ;;当ERRNO返回7，表明用户鼠标的拾取点上没有对象，变量E设为T确保while继续。若ERRNO返回52则表明用户右击鼠标放弃选择。
      (cond ((= (setq ERR (getvar 'ERRNO)) 7)
         (setq E T)
         (princ "未选择对象。")
        )
        ((= ERR 52) (setq E nil))
      )
    )
  )
  (setvar 'PICKFIRST PF)
  RT
)
;;159 [功能] 块爆破(属性转成文字)burst
(Defun C:HH:BURST2 (/ ENAME SS1)
  ;;1  Item from association list
  (Defun ITEM (N E) (CDR (Assoc N E)))
  ;;2  Convert Attribute Entity to Text Entity
  (Defun ATT-TEXT (AENT / TENT ILIST INUM)
    (Setq TENT '((0 . "TEXT")))
    (ForEach INUM
         '(8 6 38 39 62 67 210 10 40 1 50 41 51 7 71 72 73 11 74)
      (If (Setq ILIST (Assoc INUM AENT))
    (Setq TENT (Cons ILIST TENT))
      )
    )
    (Setq tent (Subst (Cons 73 (item 74 aent)) (Assoc 74 tent) tent))
    (EntMake (Reverse TENT))
  )
  ;;3  BURST-ONE
  (Defun BURST-ONE1
     (BNAME / AENT AGAIN ANAME ATYPE BENT ENAME SS SS1 SS2)
    (Setq BENT (EntGet BNAME))
    (If    (= 1 (ITEM 66 BENT))        ;如果是属性块
      (Progn (Setq ANAME BNAME)
         (While (Setq ANAME    (EntNext ANAME)
              AENT    (EntGet ANAME)
              ATYPE    (ITEM 0 AENT)
              AGAIN    (= "ATTRIB" ATYPE)
            )
           (ATT-TEXT AENT)
         )
      )
    )
    (command "_.explode" bname)
    (setq ss (ssget "_p"))
    (setq ss2 (ssget "_p" '((0 . "ATTDEF"))))
    (command "._Select" ss "")
    (setq ss1 (ssget "_p" '((0 . "INSERT"))))
    (if    ss2
      (command "_.erase" ss2 "")
    )
    (If    SS1
      (Progn
    (Repeat    (SsLength SS1)
      (Setq ENAME (SsName SS1 0))
      (SsDel ENAME SS1)
      (BURST-ONE1 ENAME)        ;递归
    )
      )
    )
  )
  ;;4 主程序
  (Setq SS1 (SsGet (list (cons 0 "INSERT"))))
  (If SS1
    (Progn (Setvar "highlight" 0)
       (terpri)
       (Repeat (SsLength SS1)
         (Setq ENAME (SsName SS1 0))
         (SsDel ENAME SS1)
         (BURST-ONE1 ENAME)
       )
       (princ "\n ")
    )
  )
  (princ)
)
;;160.1 [功能] 获取指定文件夹(不包括子文件夹)下所有满足扩展名的文件
 (defun GetFullPath (path)
  (if (wcmatch path "*\\")
    path
    (strcat path "\\")
  )
)
;;返回列表文件表元素全为小写
；；示例(GetAllSpecFilesInFolder "D:\\TEMP\\" "*.dwg")
(defun GetAllSpecFilesInFolder (dir filter)
  (mapcar
    (function
      (lambda (file)
    (strcase (strcat (getfullpath dir) file) T)
      )
    )
    (vl-directory-files dir filter 1)
  )
)
;;160.2 [功能] 获取指定文件夹(包括子文件夹)下所有满足扩展名的文件
;; 示例(GetAllSpecFilesInFolders "D:\\TEMP\\" "*.dwg")
(defun GetAllSpecFilesInFolders    (dir filter / filenames)
  (setq    filenames (mapcar
            (function
              (lambda (file)
            (strcase (strcat (getfullpath dir) file) T)
            ;;递归出口
              )
            )
            (vl-directory-files dir filter 1)
          )
  )
  (mapcar
    (function
      (lambda (subdir)
    ;; 此处递归
    (setq filenames    (append    filenames
                (GetAllSpecFilesInFolders
                  (strcat (getfullpath dir) subdir)
                  filter
                )
            )
    )
      )
    )
    (vl-remove-if
      (function    (lambda    (subdir)
          (member subdir '("." ".."))
        )
      )
      (vl-directory-files dir nil -1)
    )
  )
  filenames
)
;;161.1 [功能] 选择集->VlaSS集合
;;(vlax-map-Collection (ss->vlass ss) 'vla-delete)
(defun ss->vlass (ss)
  (command "_.select" ss "")
  (vla-get-activeselectionset
    (vla-get-ActiveDocument (vlax-get-acad-object))
  )
)
;; 161.2 [功能]将一个选择集转化为VLA集合 by裸奔的花猫
(defun ss->vlass (ss / DOC I KJ SSET NSET VLA)
  (setq    doc  (vla-get-activedocument (vlax-get-acad-object))
    sset (vla-get-selectionsets doc)
  )
  ;;有选择集$Set，则先删除,或者(vla-Clear $Set);清空$Set
  (if (vl-catch-all-error-p
    (vl-catch-all-apply 'vla-item (list sset "$Set"))
      )
    nil
    (vla-delete (vla-item sset "$Set"))
  )
  (setq nset (vla-add sset "$Set"))          ;新建一个VLA选择集  
  ;;得到VLA物体列表
  (repeat (setq i (sslength ss))
    (setq vla (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
    (setq kj (cons vla kj))
  )
  (vlax-invoke nset 'additems kj)
  nset
)