分享！Xrecord功能
以下代码源于XDCAD。ORG，作者是自由撰稿人;;Set Xrecord
;;bbs.xdcad.org
;;Author:Free-Lancer
(defun Obj:SetXrecord (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) "AcDbDictionary")
(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-objectname dict) "AcDbXrecord")
(= (strcase (vla-get-name dict)) (strcase name))
)
(setq xrec dict)
)
)
(if xrec
(progn
(vla-getxrecorddata xrec 'xt 'xd)
(_setxrecord
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-addxrecord dict name)
)
(_setxrecord xrec values)
)
)
)
)
;;获取Xrecord
;; Get Xrecord
;;bbs.xdcad.org
;;Author:Free-Lancer
(defun Obj:GetXrecord (obj name / e dicts xd xt lst _getxrecord)
(defun _getxrecord (dc / xt xd)
(if (= (vla-get-objectname 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
)
)
)
;;删除Xrecord
;;bbs.xdcad.org
;;Author:Free-Lancer
(defun obj:DeleteXrecord (obj name /)
(if (= (vla-get-objectname obj) "AcDbDictionary")
(vlax-for d obj
(if (= (vla-get-objectname d) "AcDbXrecord")
(if (= name "*")
(vla-delete d)
)
(if (= (strcase (vla-get-name d)) (strcase name))
(vla-delete d)
)
)
)
(if (vla-get-hasextensiondictionary obj)
(vlax-for d (vla-getextensiondictionary obj)
(if (= (vla-get-objectname d) "AcDbXrecord")
(if (= name "*")
(vla-delete d)
)
(if (= (strcase (vla-get-name d)) (strcase name))
(vla-delete d)
)
)
)
)
)
)
;;更换Xrecord
;;bbs.xdcad.org
;;Author:Free-Lancer
(defun OBJ:ReplaceXrecord (obj name vars / oldvars lst tf)
(if (setq lst (obj:getxrecord obj name))
(progn
(setq oldvars (mapcar 'car vars)
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)))
tf t
)
(setq vars (vl-remove (car ll) vars))
nx
)
x
)
)
lst
)
)
(if tf
(obj:setxrecord obj name lst)
)
t
)
)
)
;;删除Xrecord
;;bbs.xdcad.org
;;Author:Free-Lancer
(defun Obj:RemoveXrecord (obj name vars / lst)
(if (setq lst (obj:getxrecord obj name))
(progn
(mapcar '(lambda (x / el)
(if (setq el (vl-member-if
'(lambda (a) (equal (cdr a) x 1e-3))
lst
)
)
(setq lst (vl-remove (car el) lst)
tft
)
)
)
vars
)
(if tf
(obj:setxrecord obj name lst)
)
t
)
)
)
页:
[1]