【base1.1】创建常用常数
(defun __PRD@INITCONST__()
(vl-load-com)
(setq *En2Obj* vlax-ename->vla-object
*Obj2En* vlax-vla-object->ename
*ACAD* (vlax-get-acad-object)
*ADOC* (vla-get-ActiveDocument *ACAD*);关于跨文件操作lisp另考虑
*DOCS* (vla-get-Documents *ACAD*)
*ADMS* (vla-get-modelSpace *ADOC*);active doc's model space
*ADPS* (vla-get-paperSpace *ADOC*);active doc's paper space
*ABLKS* (vla-get-Blocks *ADOC*);
*ALAYS* (vla-get-Layers *ADOC*)
*ADICS* (vla-getDictionaries *ADOC*)
*ALTPS* (vla-get-Linetypes *ADOC*)
*ATXTS* (vla-get-TextStyles *ADOC*)
*AGRPS* (vla-get-groups *ADOC*)
*ADIMS* (vla-get-DimStyles *ADOC*)
*LOUTS* (vla-get-Layouts *ADOC*)
*AVWPS* (vla-get-Viewports *ADOC*)
*AVIEW* (vla-get-Views *ADOC*)
)
(setq *PSHELL* (vlax-get-or-create-object "Shell.Application")
*REGEXP* (vlax-get-or-create-object "VBScript.RegExp")
*WSSHEL*(vlax-get-or-create-object "wscript.shell")
*SCPCON* (vlax-get-or-create-object "ScriptControl")
*WBEMSL* (vlax-get-or-create-object "WbemScripting.SWbemLocator")
);常用外部接口对象 考虑regexp的一类版本判断
【base1.2】获取任意对象句柄的所有属性和方法
(defun VGET_OBJ_CONTENT(obj)
(if (= (type obj) 'VLA-OBJECT)
(if (not (vlax-object-released-p obj));待完善
(vlax-dump-object obj T)
"NaN"
)
"NaN"
)
)
【base1.3】安全获取任意对象句柄的属性
(defun VGET_PTY_X(obj pty)
(if (= (type obj) 'VLA-OBJECT)
(if (vlax-property-available-p obj pty)
(vlax-get-property obj pty)
nil
)
nil
)
)
【base1.4】获取集合成员的名称列表
(defun VGET_OBJ_NAME(obj)
(if (vlax-property-available-p obj 'Name)
(vlax-get-property obj 'Name)
"NaN"
)
)
(defun VGET_COL_ITEM_NAME(collection / out)
(vlax-for each collection
(setq out (cons (VGET_OBJ_NAME each) out))
)
(reverse out)
)
【base1.4】获取acad的preferences对象句柄
(defun __PRD@ADOCPREF__()
(VGET_PTY_X *ACAD* 'Preferences)
)
【base1.5】获取指定的preferences的对象句柄
(defun GETPREFKEY(tab key / prefs)
(setq prefs (__PRD@ADOCPREF__))
(if perfs
(VGET_PTY_X prefs key)
nil
)
)
【base1.6】设置preferences对象中的属性
(defun PUTPREFKEY(tab key val)
(setq prefi (VGET_PTY_X (__PRD@ADOCPREF__) tab))
(if prefi
(if (vlax-property-available-p
prefi
key
T
)
(vlax-put-property prefi key val)
"NaN"
)
"NaN"
)
)
【base1.7】返回词典集合成员名称列表
(defun )
【base5.1】获取对象XRECORD
(defun GETXRECORD(obj name / e dicts xt xd lst _getxrecord)
(defun _getxrecord(dc / xt xd)
(if (= (vla-get-objname dc) "AcDbXrecord")
(progn (vla-getxrecorddata dc 'xt 'xd)
(if (and xt xd)
(setq lst
(cons
(cons (vla-get-name dc)
(mapcar '(lambda (x y) (cons x y))
(safearray-value xt)
(mapcar 'variant-value (safearray-value xd))
);
);
lst
);
);
(setq lst (cons (vla-get-name dc) lst))
);
);
);
);
(if (= (vla-get-objectname obj) "AcDbDictionary")
(vlax-for dict obj
(_getxrecord dict)
)
(if (= (vla-get-hasExtensionDictionary obj) :vlax-true)
(progn (setq dicts (vla-getExtensionDictionary obj))
(vlax-for dict dicts
(_getxrecord dict)
)
)
)
)
(if (= name "*")
lst
(vl-remove-if-not
'(lambda(x) (= (strcase (car x)) (strcase name)))
lst
)
)
)
【base5.2】为对象贴附XRECORD
(defun PUTXRECORD(obj name values / _setxrecord xlst xrec dicts xd xt)
(defun _setxrecord(obj lst)
(vla-setxrecorddata obj
(list->vbarray (mapcar 'car lst) vlax-vbinteger)
(list->vbarray (mapcar 'cdr lst) vlax-vbvariant)
)
)
(if (= (vla-get-objectname obj) "AaDbDictionary")
(progn
(vlax-for d obj
(if (and (= (vla-get-objectname d) "AcDbXrecord")
(= (strcase (vla-get-name d)) (strcase name))
)
(setq xrec d)
)
)
(if xrec
(progn (vla-getxrecorddata xrec 'xt 'xd)
(if xt
(_setxrecord xrec
(append
(mapcar '(lambda (x y) (cons x y))
(safearray-value xt)
(mapcar 'variant-value (safearray-value xd))
)
values
);
);
(_setxrecord xrec values)
);
);
(progn (setq xrec (vla-addxrecord obj name))
(_setxrecord xrec values)
)
);
);
(if (= (vla-get-hasExtensionDictionary obj) :vlax-true)
(progn
(setq dicts (vla-GetExtensionDictionary obj))
(vlax-for dict dicts
(if (and (= (vla-get-objname dict) "AcDbXrecord")
(= (strcase (vla-get-name dict)) (strcase name))
)
(setq xrec dict)
)
)
(if xrec
(progn (vla-getxrecorddata xrec 'xt 'xd)
(_setrecord xrec
(append
(mapcar '(lambda (x y) (cons x y))
(safearray-value xt)
(mapcar 'variant-value (safearray-value xd))
)
values
)
)
)
);
);
(progn
(setq dict (vla-getextensiondictionary obj)
xrec (vla-addrecord dict name)
)
(_setxrecord xrec values)
)
);
);
);
【base5.3】删除对象的XRECORD （删除对象是否彻底呢？）
(defun DELXRECORD(obj name /)
(if (= (vla-get-objname obj) "AcDbDictionary")
(vlax-for d obj
(if (= (vla-get-objname d) "AcDbXrecord")
;(progn///////?有吗
(if (= name "*")
(vla-delete d)
)
(if (= (strcase (vla-get-name d)) (strcase name))
(vla-delete d)
)
;)////////?有吗
)
)
(if (vla-get-hasexteinsiondictionary obj)
(vlax-for d (vla-getextensiondictionary obj)
(if (= (vla-get-objectname d) "AcDbXrecord")
;(progn////////?有吗
(if (= name "*")
(vla-delete d)
)
(if (= (strcase (vla-get-name d)) (strcase name))
(vla-delete d)
)
;)//////////有吗
)
)
)
)
)
【base5.4】替换对象的相同名称的XRECORD
(defun REPLACEXRECORD(obj name vars / oldvars lst tf)
(if (setq lst (GETXRECORD obj name))
(progn
(setq oldvars (mapcar 'car vars))
(setq lst
(mapcar
'(lambda (x / ll nx)
(if (setq ll (vl-member-if '(lambda (a) (equal a x 1e-3)) oldvars))
(progn
(setq nx (cons (car x) (cadr (assoc (car ll) vars))))
(setq tf T)
(setq vars (vl-remove (car ll) vars))
nx
)
x
)
)
lst
)
)
(if tf
(SETXRECORD obj name lst)
)
T
)
)
)