Sharing ! Xrecord function

[AIberto]

The following code sources from XDCAD.ORG , Author is Free-Lancer

 

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

 

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

 

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

 

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

 

;;Remove 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)
                        tf  t
                  )
                )
              )
             vars
     )
     (if tf
       (obj:setxrecord obj name lst)
     )
     t
   )
 )
)