字典操作

dcl1214 · 发表于 5 天前

本帖最后由 dcl1214 于 2025-6-1 14:30 编辑

字典操作，一起测试
感谢石总帮助

(defun $zi-dian-xie-ru$
(ent name values lst /
_setxrecord alls dict dicts
list->vbarray news obj obj0
olds xd xlst xrec xt
)
;字典写入
;($zi-dian-xie-ru$(CAR (entsel)) "ZXCAD" '((1000 . "HELLO WORLD") (1070 . 1) (1040 . 1.0))nil)
(defun _setxrecord (obj lst)
(vla-setxrecorddata
obj
(list->vbarray (mapcar 'car lst) vlax-vbinteger)
(list->vbarray (mapcar 'cdr lst) vlax-vbvariant)
)
)
(defun list->vbarray (ptsList TYPE1 / arraySpace sArray)
(setq arraySpace
(vlax-make-safearray
TYPE1
(cons 0 (- (length ptsList) 1))
)
)
(setq sArray (vlax-safearray-fill arraySpace ptsList))
(vlax-make-variant sArray)
)
(if (and ent (= (type ent)) 'ename)
(setq obj0 (vlax-ename->vla-object ent))
)
(and obj0 (setq obj (VLA-GetExtensionDictionary obj0)))
(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
(progn
(setq olds
(mapcar 'cons
(safearray-value xt)
(mapcar 'variant-value (safearray-value xd))
)
)
(setq
alls (vl-remove nil (append olds values))
)
(cond
((vl-position (cdr (assoc "模式" lst)) (list "追加"))
(setq news alls)
)
(t (setq news values))
)
(_setxrecord xrec news)
)
(_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 'cons
(safearray-value xt)
(mapcar 'variant-value (safearray-value xd))
)
values
)
)
)
)
)
(progn
(setq dict (vla-getextensiondictionary obj)
xrec (vla-addxrecord dict name)
)
(_setxrecord xrec values)
)
)
)
($zi-dian-du-qu$ ent "*" nil)
)
(defun $zi-dian-du-qu$
(ent name lst / _getxrecord dicts e obj obj0 xd xt)
;字典读取
;($zi-dian-du-qu$(CAR (entsel)) "*" nil)
;($zi-dian-du-qu$(CAR (entsel)) "ZXCAD" nil)
(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
'cons
(safearray-value xt)
(mapcar 'variant-value (safearray-value xd))
)
)
lst
)
)
(setq lst (cons (vla-get-name dc) lst))
)
)
)
)
(if (and ent (= (type ent)) 'ename)
(setq obj0 (vlax-ename->vla-object ent))
)
(and obj0 (setq obj (VLA-GetExtensionDictionary obj0)))
(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
(function (lambda (x) (= (strcase (car x)) (strcase name))))
lst
)
)
)
(defun $zi-dian-shan-chu$
(ent name vars lst / E1 obj obj0 OLDS SS TF X)
;字典删除
;($zi-dian-shan-chu$(CAR (entsel)) "ZXCAD" '((1070 . 1) (1040 . 2.0)) nil)
(if (and ent (= (type ent)) 'ename)
(setq obj0 (vlax-ename->vla-object ent))
)
(and obj0 (setq obj (VLA-GetExtensionDictionary obj0)))
(if (setq OLDS ($zi-dian-du-qu$ ent name NIL))
(progn
(setq olds (cdr (assoc name OLDS)))
(COND
((AND obj name vars)
(setq OLDS (vl-remove-if
(function (lambda (a) (assoc (car a) vars)))
OLDS
)
)
(if OLDS
($zi-dian-xie-ru$ ent name OLDS lst)
)
)
(T
(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)
)
)
)
)
)
)
)
(setq OLDS ($zi-dian-du-qu$ ent name NIL))
)
)
OLDS
)

(defun $zi-dian-xie-ru$ 
                        (ent          name           values   lst             / 
                         _setxrecord           alls            dict     dicts 
                         list->vbarray           news            obj             obj0 
                         olds          xd           xlst            xrec     xt 
                        ) 
                                        ;字典写入 
                                        ;($zi-dian-xie-ru$(CAR (entsel))  "ZXCAD" '((1000 . "HELLO WORLD") (1070 . 1) (1040 . 1.0))nil) 
  (defun _setxrecord (obj lst) 
    (vla-setxrecorddata 
      obj 
      (list->vbarray (mapcar 'car lst) vlax-vbinteger) 
      (list->vbarray (mapcar 'cdr lst) vlax-vbvariant) 
    ) 
  ) 
  (defun list->vbarray (ptsList TYPE1 / arraySpace sArray) 
    (setq arraySpace 
           (vlax-make-safearray 
             TYPE1 
             (cons 0 (- (length ptsList) 1)) 
           ) 
    ) 
    (setq sArray (vlax-safearray-fill arraySpace ptsList)) 
    (vlax-make-variant sArray) 
  ) 
  (if (and ent (= (type ent)) 'ename) 
    (setq obj0 (vlax-ename->vla-object ent)) 
  ) 
  (and obj0 (setq obj (VLA-GetExtensionDictionary obj0))) 
  (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 
            (progn 
              (setq olds 
                     (mapcar 'cons 
                             (safearray-value xt) 
                             (mapcar 'variant-value (safearray-value xd)) 
                     ) 
              ) 
              (setq 
                alls (vl-remove nil (append olds values)) 
              ) 
              (cond 
                ((vl-position (cdr (assoc "模式" lst)) (list "追加")) 
                 (setq news alls) 
                ) 
                (t (setq news values)) 
              ) 
              (_setxrecord xrec news) 
            ) 
            (_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        'cons 
                        (safearray-value xt) 
                        (mapcar 'variant-value (safearray-value xd)) 
                ) 
                values 
              ) 
            ) 
          ) 
        ) 
      ) 
      (progn 
        (setq dict (vla-getextensiondictionary obj) 
              xrec (vla-addxrecord dict name) 
        ) 
        (_setxrecord xrec values) 
      ) 
    ) 
  ) 
  ($zi-dian-du-qu$ ent "*" nil) 
) 
(defun $zi-dian-du-qu$ 
       (ent name lst / _getxrecord dicts e obj obj0 xd xt) 
                                        ;字典读取 
                                        ;($zi-dian-du-qu$(CAR (entsel))   "*"  nil) 
                                        ;($zi-dian-du-qu$(CAR (entsel))   "ZXCAD"  nil) 
  (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 
                                'cons 
                                (safearray-value xt) 
                                (mapcar 'variant-value (safearray-value xd)) 
                              ) 
                        ) 
                        lst 
                      ) 
               ) 
               (setq lst (cons (vla-get-name dc) lst)) 
             ) 
      ) 
    ) 
  ) 
  (if (and ent (= (type ent)) 'ename) 
    (setq obj0 (vlax-ename->vla-object ent)) 
  ) 
  (and obj0 (setq obj (VLA-GetExtensionDictionary obj0))) 
  (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 
       (function (lambda (x) (= (strcase (car x)) (strcase name)))) 
       lst 
     ) 
  ) 
) 
(defun $zi-dian-shan-chu$ 
       (ent name vars lst / E1 obj obj0 OLDS SS TF X) 
                                        ;字典删除 
                                        ;($zi-dian-shan-chu$(CAR (entsel))   "ZXCAD" '((1070 . 1) (1040 . 2.0))  nil) 
  (if (and ent (= (type ent)) 'ename) 
    (setq obj0 (vlax-ename->vla-object ent)) 
  ) 
  (and obj0 (setq obj (VLA-GetExtensionDictionary obj0))) 
  (if (setq OLDS ($zi-dian-du-qu$ ent name NIL)) 
    (progn 
      (setq olds (cdr (assoc name OLDS))) 
      (COND 
        ((AND obj name vars) 
         (setq OLDS (vl-remove-if 
                      (function (lambda (a) (assoc (car a) vars))) 
                      OLDS 
                    ) 
         ) 
         (if OLDS 
           ($zi-dian-xie-ru$ ent name OLDS lst) 
         ) 
        ) 
        (T 
         (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) 
                 ) 
               ) 
             ) 
           ) 
         ) 
        ) 
      ) 
      (setq OLDS ($zi-dian-du-qu$ ent name NIL)) 
    ) 
  ) 
  OLDS 
)

664571221 · 发表于 5 天前

强哥这么厉害吗，大佬你厉害还是强哥厉害.

czb203 · 发表于 5 天前

大佬介绍下怎么使用呀

Bao_lai · 发表于 5 天前

增删读，改？

dcl1214 · 发表于 5 天前

本帖最后由 dcl1214 于 2025-6-2 10:08 编辑

(setq ent-text(car(entsel "请点击一个文字")))
(setq ent-line(car(entsel "请点击一根直线")))
(setq obj(vlax-ename->vla-object ent-text))
(setq text-objid(vla-get-objectid obj));文字的objid
(setq txt-jb(cdr(assoc 5(entget ent-text))));文字句柄
($zi-dian-xie-ru$ ent-line "ZXCAD" (list(cons 330 txt-jb))nil);将文字的id写入到直线里面，当用户复制图纸的时候，绑定关系依然成立
(cdr(assoc 330(cdr(assoc "ZXCAD"($zi-dian-du-qu$ (CAR (entsel)) "ZXCAD" nil)))));读取看看

dcl1214 · 发表于 4 天前

(defun $objid>ent$ (objID / ent)
  (if objID
(setq ent (vl-catch-all-apply
'vlax-vla-object->ename
(list
   (vl-catch-all-apply
      'vla-ObjectIdToObject
      (list
      (vla-get-activedocument (vlax-get-acad-object))
      objID
      )
   )
)
      )
)
  )
  (if (vl-catch-all-error-p ent)
(setq ent nil)
  )
  ent
)

czb203 · 发表于 3 天前

大佬介绍下运用场景~

黄翔 · 发表于前天 12:16

dcl1214 发表于 2025-6-1 23:58

(cdr(assoc 330(cdr(assoc "ZXCAD"($zi-dian-du-qu$ (CAR (entsel)) "ZXCAD" nil)))));读取看看
读取了,是个安全数组.vlax-safearray->list 解析了是个表.如何返回实体的objectID啊.

xudongchu · 发表于昨天 08:46

有错误~~~~~

qwsss31 · 发表于昨天 08:59

就这么完事调试了可以啊

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

字典操作

评分

本帖子中包含更多资源