AIberto Posted October 26, 2014 Share Posted October 26, 2014 The following code sources from XDCAD.ORG , Author is Free-Lancer ;;Set xdata ;;Set xdata ;;bbs.xdcad.org ;;Author:Free-Lancer (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 ) ;;Remove Xdata ;;Remove Xdata ;;bbs.xdcad.org ;;Author:Free-Lancer (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 ) ) ) ;;Remove Xdata ;; Replace xdata ;;bbs.xdcad.org ;;Author:Free-Lancer (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) ) ) ) Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.