玩转 XData
本帖最后由 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
（待续）
支持，再严重支持 支持，严重支持，请继续。。。。。。 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
)
)
)
) 本帖最后由 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:19 编辑
接上篇
知道组码意思后就可使用 XDATA 根据需要保存自己数据了，下面设置 XData 采用 Vla 方式，entmod 方法可以在网上搜索相关代码
ActiveX 提供了 setXdataMethod
先看看说明
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
)
)
)
接上篇
设置 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
)
下面是 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: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
)
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
;|
替换指定 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)
)
)
) 谢谢大师的贡献！感觉好深奥，这个能做些什么吗？大师何不写个相关的实用程序出来？ xiexiele!!!!!!!!!!!!! 本帖最后由 iLisp 于 2014-10-26 20:42 编辑
1004是不是可以保存本书？或者把二进制文件转换后保存？最大有什么限制？ 学习.~~~~~~~~~~~~~~ 好人一生平安，谢谢 支持，再严重支持
页:
[1]
2