玩转 XRecord

Free-Lancer · 发表于 2014-10-25 11:37:43

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

XRecord 提供了比 XData 更灵活的数据存储
以下组码是所有 XRECORD 对象共有的组码。除此处所述的组码以外，另请参见常用对象组码。关于此表中使用的缩写和格式方面的信息，请参见本参考的格式惯例。

XRECORD 组码
组码	说明
100	子类标记 (AcDbXrecord)
280	重复记录克隆标志（决定如何合并重复条目）： 0 = 不适用 1 = 保留现有项 2 = 使用克隆 3 = <外部参照>$0$<名称> 4 = $0$<名称> 5 = 未损坏名称
1–369（5 和 105 除外）	这些值可由应用程序以任何方式使用

XRECORD 对象可用于存储和管理任意数据。它们由 DXF 组码和“普通对象”组码（即非扩展数据组码）构成，支持的范围为 1 到 369。此对象在概念上与扩展数据类似，但没有尺寸或次序的限制。
XRECORD 对象的工作方式使得在 R13c0 到 R13c3 版本之间不会发生冲突。但是，如果读入到 AutoCAD® R13c4 之前的版本中，XRECORD 对象将消失。

获取附着在 Dictionary 或 Object 上的 XRecord

;|
获取Xrecord
obj --- all drawing object or dictionary
name -- appid string
|;
(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 
obj --- all drawing object  or dictionary 
name -- appid string 
|; 
(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 
    ) 
  ) 
)

Free-Lancer · 发表于 2014-10-25 19:37:52

本帖最后由 Free-Lancer 于 2014-10-25 19:39 编辑

设置 XRecord 和 Xdata 类似
单元素的用点对表, 点形式用表如 ((1 . "adafd") (10 1.0 0.0 0.0) ....)

;|
设置 xrecord 追加型
obj --- all drawing object or dictionary
name --- string , key
values --- data 表
|;
(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 追加型 
obj    --- all drawing object or dictionary 
name   --- string , key 
values --- data  表 
|; 
(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) 
      ) 
    ) 
  ) 
)

Free-Lancer · 发表于 2014-10-25 19:41:11

本帖最后由 Free-Lancer 于 2014-10-26 20:13 编辑

删除 XRecord

;;删除 xrecord
(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)
)
)
)
)
)
)

Free-Lancer · 发表于 2014-10-25 19:44:57

本帖最后由 Free-Lancer 于 2014-10-26 20:05 编辑

;|
替换指定值
obj ---- dictionary or object
name --- string
vars --- list ((oldvalues1 newvalues1) (oldvalues2 newvalues2) ....)
|;
(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
)
)
)

;| 
替换指定值 
obj ----  dictionary or object 
name ---  string 
vars ---  list ((oldvalues1 newvalues1) (oldvalues2 newvalues2) ....) 
|; 
(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 
    ) 
  ) 
)

dnbcgrass · 发表于 2014-10-25 21:47:35

学习学习{:soso_e179:}{:soso_e179:}{:soso_e179:}{:soso_e179:}

iLisp · 发表于 2014-10-25 21:47:37

Free-Lancer 发表于 2014-10-25 19:44

这个贴错了吧，和设置内容一样！

Free-Lancer · 发表于 2014-10-26 20:11:53

iLisp 发表于 2014-10-25 21:47
这个贴错了吧，和设置内容一样！

3、4楼代码已更新

;|
移除指定数据的 Xrecord
obj ---- dictionary or object
name --- string
vars --- list of values
|;
(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)
tf t
)
)
)
vars
)
(if tf
(obj:setxrecord obj name lst)
)
t
)
)
)

账号		自动登录	找回密码
密码			立即注册

[教学] 玩转 XRecord

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

点评

点评

浏览过的版块