玩转 XData

Free-Lancer · 发表于 2014-10-24 13:43:44

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

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

x

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

最近系统看来看 XDATA 的Help和一些函数，总结一下，XData 是可以附着在多种类型 Object 上的，看ActiveX help，以下类型 Object 均可以设置 xdata
All Drawing Objects , AttributeReference, Block, Dictionary, DimStyle, Group, Layer, Linetype, PlotConfigurations, RegisteredApplication, TextStyle, UCS, View, Viewport; XRecord

xdata 可以建立自己数据而不和其它数据冲突，建立自己的数据首先要建立一个索引以指向自己的数据，在 DXF 中这个索引是 1001 组码，首先看看如何查看附着在 Object 上的 Xdata

(defun OBJ:GetXdataName (e / el lst)
(if (= (type e) 'VLA-OBJECT)
(setq e (vlax-vla-object->ename e))
)
(if (and (setq el (entget e '("*")))
(setq lst (assoc -3 el))
)
(mapcar 'car (cdr lst))
)
)

每个 XDATA 必须要有一个自己名字，在 DXF 中用 1001 组码，一个 Object 可以注册多个 1001 索引的 xdata，上面函数就是获取附着在 Object 上的所有 APPID

（待续）

y5664491 · 发表于 2015-10-24 02:32:05

支持，再严重支持

/db_自贡黄明儒_ · 发表于 2014-10-24 15:11:52

支持，严重支持，请继续。。。。。。

Free-Lancer · 发表于 2014-10-25 09:19:00

2 获取指定名称扩展数据

这里用 entget 比较简单，DXF 提供了所有 XDATA 组码，获取表后可以使用 assoc 检索，当然用 (vla-getxdata obj appname 'xt 'xd) 也可以， xt xd 是输出参数，和 vla-intersectwith 中的参数用法相同，获取后用 (safearray-value xt) 取得的是组码，(mapcar 'variant-value (safearray-value xd))就是各个值了，注意 vla-getxdata 必须提供 appname 参数才可以获取 xdata

;|
获取实体指定名称的 xdata, name 为 "*" 或 t 列出所有
obj --- object or entity
name -- AppID name string
|;
(defun obj:GetXdata (obj Name / el lst)
(if (= (type e) 'VLA-OBJECT)
(setq e (vlax-vla-object->ename e))
)
(if (setq el (cdr (assoc -3
(entget (if (= (type obj) 'ENAME)
obj
(vlax-vla-object->ename obj)
)
'("*")
)
)
)
)
(if (or (= name "*") (= name T))
el
(if (setq lst (assoc (strcase name)
(mapcar '(lambda (x)
(cons (strcase (car x)) (cdr x))
)
el
)
)
)
lst
)
)
)
)

;| 
获取实体指定名称的 xdata, name 为 "*" 或 t 列出所有 
obj --- object or entity 
name -- AppID name string 
|; 
(defun obj:GetXdata (obj Name / el lst) 
  (if (= (type e) 'VLA-OBJECT) 
    (setq e (vlax-vla-object->ename e)) 
  ) 
  (if (setq el (cdr (assoc -3 
                           (entget (if (= (type obj) 'ENAME) 
                                     obj 
                                     (vlax-vla-object->ename obj) 
                                   ) 
                                   '("*") 
                           ) 
                    ) 
               ) 
      ) 
    (if        (or (= name "*") (= name T)) 
      el 
      (if (setq        lst (assoc (strcase name) 
                           (mapcar '(lambda (x) 
                                      (cons (strcase (car x)) (cdr x)) 
                                    ) 
                                   el 
                           ) 
                    ) 
          ) 
        lst 
      ) 
    ) 
  ) 
)

Free-Lancer · 发表于 2014-10-25 11:02:09

本帖最后由 Free-Lancer 于 2014-10-25 11:07 编辑

3 设置 XDATA

设置之前先看看 XDATA 组码说明

这里面需要注意的是 1010 1011 1012 1013 组码，说明中是指 dxf 文件中的存储方式，不是实体的存储方式，在实体XDATA中该四个组码存储的是3D点，并不使用 1020 1030 1021 1031 1022 1032 1023 1033 几个组码

以上组码记忆起来很麻烦，写了一个用索引方法

(defun OBJ:XdataHelp ()
(foreach x
'(("String" 1000 "字符串")
("CTRL" 1002 "编组控制符{}")
("Layer" 1003 "图层名")
("DADA" 1004 "二进制数据")
("Handle" 1005 "图元句柄, 16进制ASCII")
("Position" 1010 "点")
("Location" 1011 "点,空间位置，随图元变化")
("Displacement" 1012 "点，空间位移，随图元变化")
("Direction" 1013 "矢量, 世界方向, 随图元变化")
("Real" 1040 "实数")
("Distance" 1041 "实数，距离, 随图元变化的实数")
("Scale" 1042 "实数，比例因子，随图元变化")
("Integer" 1070 "16位整数")
("Long" 1071 "32位整数")
)
(princ "\n")
(princ x)
)
(princ)
)

Free-Lancer · 发表于 2014-10-25 11:17:34

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

接上篇

知道组码意思后就可使用 XDATA 根据需要保存自己数据了，下面设置 XData 采用 Vla 方式，entmod 方法可以在网上搜索相关代码

ActiveX 提供了 setXdata  Method

先看看说明

object.SetXData XDataType, XData

Object    All Drawing Objects , AttributeReference, Block, Dictionary, DimStyle, Group, Layer, Linetype, PlotConfigurations, RegisteredApplication, TextStyle, UCS, View, Viewport; XRecord
The object or objects this method applies to.

XDataType Variant (array of short); input-only  组码（1001 1000 1010 等）safearray 类型

XData          Array of Variant; input-only  与组码对应的值，必须和 XDataType 一样对应，也是 safearray 类型，内部是 variant

该方法只有两个参数，使用中必须包含 1001 确定名称才可以使用，不包含 1001 的设置将会失败，

两个参数均为 Array

下面是一个通用函数，可以将 Lisp 的表转换为需要的 Array

(defun list->vbArray (lst varType / _makearray)
(defun _makearray (lst)
(vlax-safearray-fill
(vlax-make-safearray
(if (apply '= (mapcar 'type lst))
(cond ((= (type (car x)) 'REAL) vlax-vbDouble)
((= (type (car x)) 'INT) vlax-vbInteger)
((= (type (car x)) 'STR) vlax-vbString)
)
vlax-vbVariant
)
(cons 0 (1- (length lst)))
)
lst
)
)
(vlax-safearray-fill
(vlax-make-safearray varType (cons 0 (1- (length lst))))
(mapcar
'(lambda (x)
(cond ((= (type x) 'list) (_makearray x))
((= (type x) 'ename) (vlax-ename->vla-object x))
(t x)
)
)
lst
)
)
)

Free-Lancer · 发表于 2014-10-25 11:27:26

接上篇

设置 XData 就必须要提供符合 DXF 标准的列表，为了记忆方便，前面提出了用字符作关键字索引方法，这样不必记忆组码，为了兼容组码和关键字索引方式，可以使用下面的函数来处理 Lisp 表，以供 vla-setxdata 使用

(defun _prossList (lst / klst nlst)
(setq klst '(("STRING" 1000)
("CTRL" 1002)
("LAYER" 1003)
("DADA" 1004)
("HANDLE" 1005)
("POSITION" 1010)
("LOCATION" 1011)
("DISPLACEMENT" 1012)
("DIRECTION" 1013)
("REAL" 1040)
("DISTANCE" 1041)
("SCALE" 1042)
("INTEGER" 1070)
("LONG" 1071)
)
)
(mapcar
'(lambda (x / key tf code)
(setq key (car x)
tf (= (type key) 'STR)
)
(cond
((or (member key
'(1000 1002 1003 1004 1040 1041 1070 1071)
)
(and tf
(member (strcase key)
'("STRING" "CTRL" "LAYER"
"DATA" "HANDLE" "REAL"
"DISTANCE" "SCALE" "INTEGER"
"LONG"
)
)
)
)
(if tf
(progn
(setq code (cadr (assoc (strcase key) klst)))
(mapcar '(lambda (x)
(setq nlst (cons (cons code x) nlst))
)
(if (listp (cdr x))
(cdr x)
(list (cdr x))
)
)
)
(mapcar '(lambda (a)
(setq nlst (cons (cons key a) nlst))
)
(if (listp (cdr x))
(cdr x)
(list (cdr x))
)
) ;_ string Int real 必须区分, 符合组码
)
)
((or (member key
'(1010 1020 1030 1011 1021 1031
1012 1022 1032 1013 1023 1033
)
)
(and tf
(member (strcase key)
'("POSITION"
"LOCATION"
"DISPLACEMENT"
"DIRECTION"
)
)
)
)
(if tf
(cond
((= (strcase key) "POSITION")
(mapcar '(lambda (a)
(setq nlst (cons (cons 1010 a) nlst))
)
(cdr x)
)
)
((= (strcase key) "LOCATION")
(mapcar
'(lambda (a)
(setq nlst (cons (cons 1011 a) nlst))
)
(cdr x)
)
)
((= (strcase key) "DISPLACEMENT")
(mapcar
'(lambda (a)
(setq nlst (cons (cons 1012 a) nlst))
)
(cdr x)
)
)
(t
(mapcar
'(lambda (a)
(setq nlst (cons (cons 1013 a) nlst))
)
(cdr x)
)
)
)
(mapcar '(lambda (a)
(setq nlst (cons (cons key a) nlst))
)
(if (listp (cdr x))
(cdr x)
(list (cdr x))
)
)
)
)
(t)
)
)
lst
)
nlst
)

(defun _prossList (lst / klst nlst) 
  (setq        klst '(("STRING" 1000) 
               ("CTRL" 1002) 
               ("LAYER" 1003) 
               ("DADA" 1004) 
               ("HANDLE" 1005) 
               ("POSITION" 1010) 
               ("LOCATION" 1011) 
               ("DISPLACEMENT" 1012) 
               ("DIRECTION" 1013) 
               ("REAL" 1040) 
               ("DISTANCE" 1041) 
               ("SCALE" 1042) 
               ("INTEGER" 1070) 
               ("LONG" 1071) 
              ) 
  ) 
  (mapcar 
    '(lambda (x / key tf code) 
       (setq key (car x) 
             tf         (= (type key) 'STR) 
       ) 
       (cond 
         ((or (member key 
                      '(1000 1002 1003 1004 1040 1041 1070 1071) 
              ) 
              (and tf 
                   (member (strcase key) 
                           '("STRING"         "CTRL"             "LAYER" 
                             "DATA"         "HANDLE"    "REAL" 
                             "DISTANCE"         "SCALE"     "INTEGER" 
                             "LONG" 
                            ) 
                   ) 
              ) 
          ) 
          (if tf 
            (progn 
              (setq code (cadr (assoc (strcase key) klst))) 
              (mapcar '(lambda (x) 
                         (setq nlst (cons (cons code x) nlst)) 
                       ) 
                      (if (listp (cdr x)) 
                        (cdr x) 
                        (list (cdr x)) 
                      ) 
              ) 
            ) 
            (mapcar '(lambda (a) 
                       (setq nlst (cons (cons key a) nlst)) 
                     ) 
                    (if        (listp (cdr x)) 
                      (cdr x) 
                      (list (cdr x)) 
                    ) 
            ) ;_  string   Int real 必须区分, 符合组码 
          ) 
         ) 
         ((or (member key 
                      '(1010   1020   1030   1011   1021   1031 
                        1012   1022   1032   1013   1023   1033 
                       ) 
              ) 
              (and tf 
                   (member (strcase key) 
                           '("POSITION" 
                             "LOCATION" 
                             "DISPLACEMENT" 
                             "DIRECTION" 
                            ) 
                   ) 
              ) 
          ) 
          (if tf 
            (cond 
              ((= (strcase key) "POSITION") 
               (mapcar '(lambda        (a) 
                          (setq nlst (cons (cons 1010 a) nlst)) 
                        ) 
                       (cdr x) 
               ) 
              ) 
              ((= (strcase key) "LOCATION") 
               (mapcar 
                 '(lambda (a) 
                    (setq nlst (cons (cons 1011 a) nlst)) 
                  ) 
                 (cdr x) 
               ) 
              ) 
              ((= (strcase key) "DISPLACEMENT") 
               (mapcar 
                 '(lambda (a) 
                    (setq nlst (cons (cons 1012 a) nlst)) 
                  ) 
                 (cdr x) 
               ) 
              ) 
              (t 
               (mapcar 
                 '(lambda (a) 
                    (setq nlst (cons (cons 1013 a) nlst)) 
                  ) 
                 (cdr x) 
               ) 
              ) 
            ) 
            (mapcar '(lambda (a) 
                       (setq nlst (cons (cons key a) nlst)) 
                     ) 
                    (if        (listp (cdr x)) 
                      (cdr x) 
                      (list (cdr x)) 
                    ) 
            ) 
          ) 
         ) 
         (t) 
       ) 
     ) 
    lst 
  ) 
  nlst 
)

下面是 vla-setxdata 设置函数

(defun _setXdata (obj lst /)
(vla-setxdata
obj
(list->array (mapcar 'car lst) vlax-vbinteger)
(list->array (mapcar 'cdr lst) vlax-vbvariant)
)
)

Free-Lancer · 发表于 2014-10-25 11:29:04

本帖最后由 Free-Lancer 于 2014-10-25 11:32 编辑

接上篇，完整设置函数如下

;|
设置 xdata 追加
obj --- entity or vla-object
name --- xdata name
lst --- 嵌套表
a. 点对表, 符合 xdata 组码格式 '((1000 . "a") (1003 . "layer") ...)
b. 表, 符合xdata组码格式
i. '((1000 "a") (1000 "b") ....)
ii. 批量格式 ((1000 "a" "b" "c") (1040 1.0 2.0) ...), 点不可以批量
c. 关键字格式，支持批量，关键字可以用 (obj:xdatahelp) 查看
如(("string" "a" "b" "c") ("position" (1.0 2.0 2.0) (1.2 1.2 0.0)) ....)
d. 以上形式的混合形式
|;
(defun Obj:SetXdata (obj name lst / _prossList _setxdata nlst oldlst)
(defun _prossList (lst / klst nlst)
(setq klst '(("STRING" 1000)
("CTRL" 1002)
("LAYER" 1003)
("DADA" 1004)
("HANDLE" 1005)
("POSITION" 1010)
("LOCATION" 1011)
("DISPLACEMENT" 1012)
("DIRECTION" 1013)
("REAL" 1040)
("DISTANCE" 1041)
("SCALE" 1042)
("INTEGER" 1070)
("LONG" 1071)
)
)
(mapcar
'(lambda (x / key tf code)
(setq key (car x)
tf (= (type key) 'STR)
)
(cond
((or (member key
'(1000 1002 1003 1004 1040 1041 1070 1071)
)
(and tf
(member (strcase key)
'("STRING" "CTRL" "LAYER"
"DATA" "HANDLE" "REAL"
"DISTANCE" "SCALE" "INTEGER"
"LONG"
)
)
)
)
(if tf
(progn
(setq code (cadr (assoc (strcase key) klst)))
(mapcar '(lambda (x)
(setq nlst (cons (cons code x) nlst))
)
(if (listp (cdr x))
(cdr x)
(list (cdr x))
)
)
)
(mapcar '(lambda (a)
(setq nlst (cons (cons key a) nlst))
)
(if (listp (cdr x))
(cdr x)
(list (cdr x))
)
) ;_ string Int real 必须区分, 符合组码
)
)
((or (member key
'(1010 1020 1030 1011 1021 1031
1012 1022 1032 1013 1023 1033
)
)
(and tf
(member (strcase key)
'("POSITION"
"LOCATION"
"DISPLACEMENT"
"DIRECTION"
)
)
)
)
(if tf
(cond
((= (strcase key) "POSITION")
(mapcar '(lambda (a)
(setq nlst (cons (cons 1010 a) nlst))
)
(cdr x)
)
)
((= (strcase key) "LOCATION")
(mapcar
'(lambda (a)
(setq nlst (cons (cons 1011 a) nlst))
)
(cdr x)
)
)
((= (strcase key) "DISPLACEMENT")
(mapcar
'(lambda (a)
(setq nlst (cons (cons 1012 a) nlst))
)
(cdr x)
)
)
(t
(mapcar
'(lambda (a)
(setq nlst (cons (cons 1013 a) nlst))
)
(cdr x)
)
)
)
(mapcar '(lambda (a)
(setq nlst (cons (cons key a) nlst))
)
(if (listp (cdr x))
(cdr x)
(list (cdr x))
)
)
)
)
(t)
)
)
lst
)
nlst
)
(defun _setXdata (obj lst /)
(vla-setxdata
obj
(list->vbarray (mapcar 'car lst) vlax-vbinteger)
(list->vbarray (mapcar 'cdr lst) vlax-vbvariant)
)
)
;;main
(setq nlst (_prossList lst))
(if (member (strcase name)
(mapcar 'strcase (obj:getxdataname obj))
)
(setq oldlst (obj:GetXdata obj name)
nlst (append oldlst nlst)
)
)
(if (= (type obj) 'ENAME)
(setq obj (vlax-ename->vla-object obj))
)
(_setXdata obj (cons (cons 1001 name) nlst))
t
)

;| 
设置 xdata 追加 
obj  --- entity or vla-object 
name --- xdata name 
lst  --- 嵌套表 
         a. 点对表, 符合 xdata 组码格式 '((1000 . "a") (1003 . "layer") ...) 
         b. 表, 符合xdata组码格式 
            i. '((1000 "a") (1000 "b") ....) 
            ii. 批量格式 ((1000 "a" "b" "c") (1040 1.0 2.0) ...), 点不可以批量 
         c. 关键字格式，支持批量，关键字可以用 (obj:xdatahelp) 查看 
            如(("string" "a" "b" "c") ("position" (1.0 2.0 2.0) (1.2 1.2 0.0)) ....) 
         d. 以上形式的混合形式 
|; 
(defun Obj:SetXdata (obj name lst / _prossList _setxdata nlst oldlst) 
  (defun _prossList (lst / klst nlst) 
    (setq klst '(("STRING" 1000) 
                 ("CTRL" 1002) 
                 ("LAYER" 1003) 
                 ("DADA" 1004) 
                 ("HANDLE" 1005) 
                 ("POSITION" 1010) 
                 ("LOCATION" 1011) 
                 ("DISPLACEMENT" 1012) 
                 ("DIRECTION" 1013) 
                 ("REAL" 1040) 
                 ("DISTANCE" 1041) 
                 ("SCALE" 1042) 
                 ("INTEGER" 1070) 
                 ("LONG" 1071) 
                ) 
    ) 
    (mapcar 
      '(lambda (x / key tf code) 
         (setq key (car x) 
               tf  (= (type key) 'STR) 
         ) 
         (cond 
           ((or        (member        key 
                        '(1000 1002 1003 1004 1040 1041 1070 1071) 
                ) 
                (and tf 
                     (member (strcase key) 
                             '("STRING"           "CTRL"      "LAYER" 
                               "DATA"           "HANDLE"    "REAL" 
                               "DISTANCE"  "SCALE"     "INTEGER" 
                               "LONG" 
                              ) 
                     ) 
                ) 
            ) 
            (if        tf 
              (progn 
                (setq code (cadr (assoc (strcase key) klst))) 
                (mapcar        '(lambda (x) 
                           (setq nlst (cons (cons code x) nlst)) 
                         ) 
                        (if (listp (cdr x)) 
                          (cdr x) 
                          (list (cdr x)) 
                        ) 
                ) 
              ) 
              (mapcar '(lambda (a) 
                         (setq nlst (cons (cons key a) nlst)) 
                       ) 
                      (if (listp (cdr x)) 
                        (cdr x) 
                        (list (cdr x)) 
                      ) 
              ) ;_  string   Int real 必须区分, 符合组码 
            ) 
           ) 
           ((or        (member        key 
                        '(1010         1020        1030   1011   1021   1031 
                          1012         1022        1032   1013   1023   1033 
                         ) 
                ) 
                (and tf 
                     (member (strcase key) 
                             '("POSITION" 
                               "LOCATION" 
                               "DISPLACEMENT" 
                               "DIRECTION" 
                              ) 
                     ) 
                ) 
            ) 
            (if        tf 
              (cond 
                ((= (strcase key) "POSITION") 
                 (mapcar '(lambda (a) 
                            (setq nlst (cons (cons 1010 a) nlst)) 
                          ) 
                         (cdr x) 
                 ) 
                ) 
                ((= (strcase key) "LOCATION") 
                 (mapcar 
                   '(lambda (a) 
                      (setq nlst (cons (cons 1011 a) nlst)) 
                    ) 
                   (cdr x) 
                 ) 
                ) 
                ((= (strcase key) "DISPLACEMENT") 
                 (mapcar 
                   '(lambda (a) 
                      (setq nlst (cons (cons 1012 a) nlst)) 
                    ) 
                   (cdr x) 
                 ) 
                ) 
                (t 
                 (mapcar 
                   '(lambda (a) 
                      (setq nlst (cons (cons 1013 a) nlst)) 
                    ) 
                   (cdr x) 
                 ) 
                ) 
              ) 
              (mapcar '(lambda (a) 
                         (setq nlst (cons (cons key a) nlst)) 
                       ) 
                      (if (listp (cdr x)) 
                        (cdr x) 
                        (list (cdr x)) 
                      ) 
              ) 
            ) 
           ) 
           (t) 
         ) 
       ) 
      lst 
    ) 
    nlst 
  ) 
  (defun _setXdata (obj lst /) 
    (vla-setxdata 
      obj 
      (list->vbarray (mapcar 'car lst) vlax-vbinteger) 
      (list->vbarray (mapcar 'cdr lst) vlax-vbvariant) 
    ) 
  ) 
  ;;main 
  (setq nlst (_prossList lst)) 
  (if (member (strcase name) 
              (mapcar 'strcase (obj:getxdataname obj)) 
      ) 
    (setq oldlst (obj:GetXdata obj name) 
          nlst         (append oldlst nlst) 
    ) 
  ) 
  (if (= (type obj) 'ENAME) 
    (setq obj (vlax-ename->vla-object obj)) 
  ) 
  (_setXdata obj (cons (cons 1001 name) nlst)) 
  t 
)

Free-Lancer · 发表于 2014-10-25 19:03:12

4 移除 XData

;|
移除指定名称 xdata 的特定数据
obj ---- vla-object
name ---- string
values ---- list or t or nil 只需要值表
t or nil 移除整个 name xdata
|;
(defun Obj:RemoveXdata (obj name values / _setXdata
xlst xt xd xdlst xtlst nxtlst
nxlst var
)
(defun _setXdata (obj lst /)
(vla-setxdata
obj
(list->vbarray (mapcar 'car lst) vlax-vbinteger)
(list->vbarray (mapcar 'cdr lst) vlax-vbvariant)
)
)
(if (= (type obj) 'ENAME)
(setq obj (vlax-ename->vla-object obj))
)
(if (member (strcase name)
(mapcar 'strcase (obj:getxdataname obj))
)
(progn
(if (or (null values) (= values T))
(_setXdata obj (list (cons 1001 name)))
(progn
(vla-getxdata obj name 'xt 'xd)
(setq xlst (mapcar 'variant-value (safearray-value xd))
xtlst (safearray-value xt)
)
(if (apply 'or (mapcar '(lambda (x) (member x xlst)) values))
(progn
(while xlst
(if (not (vl-member-if
'(lambda (x)
(equal (car xlst) x 1e-3)
)
values
)
)
(setq nxlst (cons (car xlst) nxlst)
values (vl-remove (car xlst) values)
nxtlst (cons (car xtlst) nxtlst)
)
)
(setq xlst (cdr xlst)
xtlst (cdr xtlst)
)
)
(if nxlst
(_setXdata obj
(mapcar '(lambda (x y) (cons x y))
(reverse nxlst)
(reverse nxtlst)
)
)
)
)
)
)
)
t
)
)
)

;| 
移除指定名称 xdata 的特定数据 
obj    ----  vla-object 
name   ----  string 
values ----  list or t or nil 只需要值表 
             t or nil 移除整个 name xdata 
|; 
(defun Obj:RemoveXdata (obj        name        values        /        _setXdata 
                        xlst        xt        xd        xdlst        xtlst        nxtlst 
                        nxlst        var 
                       ) 
  (defun _setXdata (obj lst /) 
    (vla-setxdata 
      obj 
      (list->vbarray (mapcar 'car lst) vlax-vbinteger) 
      (list->vbarray (mapcar 'cdr lst) vlax-vbvariant) 
    ) 
  ) 
  (if (= (type obj) 'ENAME) 
    (setq obj (vlax-ename->vla-object obj)) 
  ) 
  (if (member (strcase name) 
              (mapcar 'strcase (obj:getxdataname obj)) 
      ) 
    (progn 
      (if (or (null values) (= values T)) 
        (_setXdata obj (list (cons 1001 name))) 
        (progn 
          (vla-getxdata obj name 'xt 'xd) 
          (setq        xlst  (mapcar 'variant-value (safearray-value xd)) 
                xtlst (safearray-value xt) 
          ) 
          (if (apply 'or (mapcar '(lambda (x) (member x xlst)) values)) 
            (progn 
              (while xlst 
                (if (not (vl-member-if 
                           '(lambda (x) 
                              (equal (car xlst) x 1e-3) 
                            ) 
                           values 
                         ) 
                    ) 
                  (setq        nxlst  (cons (car xlst) nxlst) 
                        values (vl-remove (car xlst) values) 
                        nxtlst (cons (car xtlst) nxtlst) 
                  ) 
                ) 
                (setq xlst  (cdr xlst) 
                      xtlst (cdr xtlst) 
                ) 
              ) 
              (if nxlst 
                (_setXdata obj 
                           (mapcar '(lambda (x y) (cons x y)) 
                                   (reverse nxlst) 
                                   (reverse nxtlst) 
                           ) 
                ) 
              ) 
            ) 
          ) 
        ) 
      ) 
      t 
    ) 
  ) 
)

Free-Lancer · 发表于 2014-10-25 19:31:36

替换 XData

;|
替换指定 xdata
|;
(defun obj:ReplaceXdata (obj name oldvars newvars
/ _replace _setxdata nl
)
(defun _setXdata (obj lst /)
(vla-setxdata
obj
(list->vbarray (mapcar 'car lst) vlax-vbinteger)
(list->vbarray (mapcar 'cdr lst) vlax-vbvariant)
)
)
(defun _replace (obj name old new / xd xt xtlst xdlst nlst tf)
(vla-getxdata obj name 'xt 'xd)
(setq xtlst (safearray-value xt)
xdlst (mapcar 'variant-value (safearray-value xd))
)
(while xdlst
(if (member (car xdlst) old)
(setq
nlst (cons (nth (vl-position (car xdlst) old)
new
)
nlst
)
tf t
)
(setq nlst (cons (car xdlst) nlst))
)
(setq xdlst (cdr xdlst))
)
(if tf
(_setxdata
obj
(mapcar '(lambda (x y) (cons x y)) xtlst (reverse nxdlst))
)
)
)
(if (setq nl (obj:getxdataname obj))
(if (or (= name "*") (= name T))
(foreach x nl
(_replace obj x oldvars newvars)
)
(if (member (strcase name) (mapcar 'strcase nl))
(_replace obj name oldvars newvars)
)
)
)

;| 
替换指定 xdata 
|; 
(defun obj:ReplaceXdata        (obj           name             oldvars   newvars 
                         /           _replace  _setxdata nl 
                        ) 
  (defun _setXdata (obj lst /) 
    (vla-setxdata 
      obj 
      (list->vbarray (mapcar 'car lst) vlax-vbinteger) 
      (list->vbarray (mapcar 'cdr lst) vlax-vbvariant) 
    ) 
  ) 
  (defun _replace (obj name old new / xd xt xtlst xdlst nlst tf) 
    (vla-getxdata obj name 'xt 'xd) 
    (setq xtlst        (safearray-value xt) 
          xdlst        (mapcar 'variant-value (safearray-value xd)) 
    ) 
    (while xdlst 
      (if (member (car xdlst) old) 
        (setq 
          nlst (cons (nth (vl-position (car xdlst) old) 
                          new 
                     ) 
                     nlst 
               ) 
          tf   t 
        ) 
        (setq nlst (cons (car xdlst) nlst)) 
      ) 
      (setq xdlst (cdr xdlst)) 
    ) 
    (if        tf 
      (_setxdata 
        obj 
        (mapcar '(lambda (x y) (cons x y)) xtlst (reverse nxdlst)) 
      ) 
    ) 
  ) 
  (if (setq nl (obj:getxdataname obj)) 
    (if        (or (= name "*") (= name T)) 
      (foreach x nl 
        (_replace obj x oldvars newvars) 
      ) 
      (if (member (strcase name) (mapcar 'strcase nl)) 
        (_replace obj name oldvars newvars) 
      ) 
    ) 
  )

lucas3 · 发表于 2014-10-25 22:32:00

谢谢大师的贡献！感觉好深奥，这个能做些什么吗？大师何不写个相关的实用程序出来？

zjy2999 · 发表于 2014-10-25 22:43:00

xiexiele!!!!!!!!!!!!!

iLisp · 发表于 2014-10-26 20:40:49

本帖最后由 iLisp 于 2014-10-26 20:42 编辑

1004是不是可以保存本书？或者把二进制文件转换后保存？最大有什么限制？

熊掌设计 · 发表于 2015-1-3 09:36:39

学习.~~~~~~~~~~~~~~

20055647 · 发表于 2015-1-9 22:21:31

好人一生平安，谢谢

tingwei3 · 发表于 2015-1-10 13:06:12

支持，再严重支持

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

[教学] 玩转 XData

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

评分

相关帖子

评分

点评

评分