Vlisp超级取属性函数

caiqs

;;;cqs   蔡全胜  2006/5/20

;;;看 大 家 都 贴,   我 也 贴 一 个  ,希望 版 主 加 分

;;;CAD二次开发交流群 3014229  欢迎高手加入

;;;超级取属性值函数
;;;(test 表 lisp对象)
;;;例 (setq obj(vlax-ename->VLA-object(car(entsel))))
;;;(test (list '(C Center) '(R Radius) '(L Layer) '(CL Color)) obj)
;;;当对象不支持属性时会在命令行报告
;;;返回值：关联表 ((c . 值)(R . 值)(L . 值))
(defun test (ptylst VLAobj / ptyval pty tempconslst ruturnconslst)
  (foreach ptyval ptylst
    (setq pty (read (vl-symbol-name (cadr ptyval))))
    (if (vlax-property-available-p VLAobj pty)
      (progn
 (set (car ptyval) (vlax-get-property VLAobj pty))
 (setq tempconslst
        (cons (car ptyval) (vl-symbol-value (car ptyval)))
 )
 (setq ruturnconslst(cons tempconslst ruturnconslst))
      )
      (princ (strcat "\n不支持属性：" (vl-symbol-name pty)))
    )
  )
  ruturnconslst
)

caiqs

;;;应版主要求,改了一下

 

;;;cqs   蔡全胜  2006/7/2

;;;看 大 家 都 贴,   我 也 贴 一 个  ,希望 版 主 加 分

;;;CAD二次开发交流群 3014229  欢迎高手加入

;;;超级图元属性值批量提取函数
;;;(getproperty 表 VLA对象)
;;;(setq obj(vlax-ename->VLA-object(car(entsel))))
;;;例1: (getproperty '((C Center)(R Radius)(L Layer)(CL Color)) obj)
;;; 例2getproperty '((0 Center) (1 Radius) (2 Layer) (3 Color)) obj)
;;;返回值：提取的关联表
(defun getproperty
       (ptylst VLAobj / ptyval pty tempconslst ruturnconslst)
  (vl-load-com)
  (cond
    ((and ptylst vlaobj)
     (foreach ptyval ptylst
       (setq pty (cadr ptyval))
       (if (vlax-property-available-p VLAobj pty)
  (progn
    (setq tempconslst
    (cons (car ptyval) (vlax-get-property VLAobj pty))
    )
    (setq ruturnconslst (cons tempconslst ruturnconslst))
  )
  (princ (strcat "\n对象不支持的属性："  (vl-symbol-name pty) "\n"))
       )
     )
     ruturnconslst
    )
;;;下边这几行模似C++的编程思想,在出错时报告函数内的信息
    (t
     (princ "\n函数 getproperty 中出现异外!")
     (princ (list ptylst VLAobj))
     nil
    )
  )
)