几个 ax:XXX 函数

st788796 · 发表于 2013-7-18 21:22:47

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

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

×

本帖最后由 st788796 于 2013-10-5 06:10 编辑

;;;转换一个AutoLISP点到一个二维ActiveX点
(defun ax:2DPoint (pt)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble '(0 . 1))
(list (car pt) (cadr pt))
)
)
)
;;;返回一个单独图元的范围
(defun ax:GetBoundingBox (ent / ll ur)
(vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
(mapcar 'vlax-safearray->list (list ll ur))
)
;;;由ActiveX变体返回LISP值
;;;===================================================
;;;Copyright 2002 Vladimir Nesterovsky
;;;===================================================
;;;第一版
;;;This previous versions weren't working with empty
;;;(defun lisp-value (v)
;;; (cond
;;; ((= (type v) 'variant)
;;; (lisp-value (vlax-variant-value v))
;;; )
;;; ((= (type v) 'safearray)
;;; (mapcar 'lisp-value (vlax-safearray->list v))
;;; )
;;; (T v)
;;; )
;;;)
;;;================================================
;;;第二版
;;;The previous versions weren't working with empty
;;;safearrays. This version seems to be better:
(defun ax:lispValue (v)
(cond
((= (type v) 'variant)
(ax:lispValue (variant-value v))
)
((= (type v) 'safearray)
(mapcar 'ax:lispValue (safearray-value v))
)
(T v)
)
)
;;;================================================
;;;Maybe its better to just write a fully recursive solution:
;;;第版
;;;作者：Vladimir Nesterovsky
;;;(defun ax:lispValue (var / vt)
;;; (cond
;;; ((/= (type var) 'variant) var)
;;; ((zerop
;;; (logand (setq vt (vlax-variant-type var)) vlax-vbarray)
;;; )
;;; (vlax-variant-value var)
;;; )
;;; ((zerop (logand vt vlax-vbvariant))
;;; (vlax-safearray->list (vlax-variant-value var))
;;; )
;;; (t
;;; (mapcar 'ax:lispValue
;;; (vlax-safearray->list
;;; (vlax-variant-value var)
;;; )
;;; )
;;; )
;;; )
;;;)
;;;转换列表为ActiveX变体数组
;;;
;;;功能
;;;
;;;转换列表为ActiveX变体数组
;;;
;;;参数
;;;
;;;lst: 列表。该列表可以有一层的嵌套深度。如(list "1" 2 (list 1.0 2.0 3.0))
;;;varType: SafeArray 的类型。
;;;
;;;返回值
;;;
;;;变体数组
;;;
;;;示例
;;;
;;;(listToVariantArray (list (list 2.0 3.0 0.0) 1 2.0 "String") vlax-vbVariant)
;;;
;;;注意
;;;
;;;如果列表中有不同的数据类型，可传递vlax-vbVariant给varType参数。
;;;要转换点列表到ActiveX坐标，可以这样写：
;;;(list->VariantArray (apply 'append ptlist) vlax-vbDouble)
(defun list->VariantArray (lst varType)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray varType (cons 0 (1- (length lst))))
(mapcar
'(lambda (x)
(cond ((= (type x) 'list)
(vlax-safearray-fill
(vlax-make-safearray
(if (apply '= (mapcar 'type x))
(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 x)))
)
x
)
)
((= (type x) 'ename)
(vlax-ename->vla-object x)
)
(t x)
)
)
lst
)
)
)
)
(defun ax:AXValue (var / vt)
(cond
((= (type var) 'ename) (vlax-ename->vla-object var))
((= (type var) 'list)
(list->VariantArray var vlax-vbVariant))
('T var)
)
)
;;;(setq *acad-object* nil) ; Initialize global variable
(defun acad-object ()
(cond (*acad-object*) ; Return the cached object
(t
(setq *acad-object* (vlax-get-acad-object))
)
)
)
;;;(setq *active-document* nil) ; Initialize global variable
(defun active-document ()
(cond (*active-document*) ; Return the cached object
(t
(setq *active-document* (vla-get-activedocument (acad-object)))
)
)
)
;;;(setq *model-space* nil) ; Initialize global variable
(defun model-space ()
(cond (*model-space*) ; Return the cached object
(t
(setq *model-space* (vla-get-modelspace (active-document)))
)
)
)
;;;用法：
;;;_$ (ax:get-property (list (acad-object) "activedocument" "activelayer" "name"))
;;;"0"
;;;_$ (ax:get-property (list (acad-object) 'activedocument 'activelayer 'name))
;;;"0"
;;;_$ (ax:get-property (list (entlast) 'layer))
;;;"0"
;;;_$ (ax:get-property (list (entlast) 'color))
;;;256
;;;_$ (ax:get-property (list (entlast) 'objectname))
;;;"AcDbPolyline"
;;;允许第一项是entity name
(defun ax:get-property (PropertyPathList / root obj)
(setq root (car PropertyPathList)
propertyPathList (cdr PropertyPathList)
)
(if (= (type root) 'ename) (setq root (vlax-ename->vla-object root)))
(foreach obj PropertyPathList
(setq root (vlax-get-property root obj))
)
root
)
;;;_$ (setq e (ax:invoke-method (list (active-document) 'modelspace 'addcircle) (list (vlax-3d-point '(3 0)) 500)))
;;;#<VLA-OBJECT IAcadCircle 0103faa4>
(defun ax:invoke-method (MethodPathList ParamList / root method obj)
(setq MethodPathList (reverse MethodPathList)
method (car methodPathList)
methodPathList (cdr MethodPathList)
root (ax:get-property (reverse MethodPathList))
)
(apply 'vlax-invoke-method
(cons root (cons method paramlist))
)
)
;;;_$ (ax:put-property (list (entlast) 'color) 2)
;;;nil
(defun ax:Put-Property (PropertyPathList value / root Prop obj)
(setq PropertyPathList (reverse PropertyPathList)
Prop (car PropertyPathList)
PropertyPathList (cdr PropertyPathList)
root (ax:get-property (reverse PropertyPathList))
)
(vlax-put-property root prop value)
)
;;; 转换选择集为变体数组
;;;
;;; 功能返回一个由选择集内容填满的子对象的变体数组。
;;;
;;; 参数 ss: 选择集
;;;
;;; 返回值变体数组
;;;
;;; 示例 (selectionsetToArray mySS)
;;;
;;; 注意使用该函数可以将选择集转换为数组传递给ActiveX函数。
;;; 如果需要其它的子类型，只需更改引用vlax-vbObject。
(defun selectionset->Array (ss / c r)
(vl-load-com)
(setq c -1)
(repeat (fix (sslength ss)) (setq r (cons (ssname ss (setq c (1+ c))) r)))
(setq r (reverse r))
(vlax-safearray-fill
(vlax-make-safearray vlax-vbObject (cons 0 (1- (length r))))
(mapcar 'vlax-ename->vla-object r)
)
)
;;; 将对象选择集添加到现有的图块定义中
;;;
;;; 功能将对象选择集添加到现有的图块定义中
;;;
;;; 参数一个图块插入的图元名称和一个包含要添加的对象的选择集
;;;
;;; 示例 (ax:AddObjectsToBlock (car (entsel)) (ssget))
;;;
;;; 注意在重新生成图形前现有的图块参照将不会显示更改内容
(defun ax:AddObjectsToBlock (blk ss / doc blkref blkdef inspt refpt)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
blkref (vlax-ename->vla-object blk)
blkdef (vla-Item (vla-get-Blocks doc) (vla-get-Name blkref))
inspt (vlax-variant-value (vla-get-InsertionPoint blkref))
ssarray (selectionset->array ss)
refpt (vlax-3d-point '(0 0 0))
)
(if (not (equal inspt refpt))
(foreach ent (vlax-safearray->list ssarray) (vla-Move ent inspt refpt))
)
(vla-CopyObjects doc ssarray blkdef)
(foreach ent (vlax-safearray->list ssarray) (vla-Delete ent))
(princ)
)
;;; 从图块定义中删除指定的子图元并返回在图块定义中所剩下的项目数
;;;
;;; 功能从图块定义中删除指定的子图元并返回在图块定义中所剩下的项目数
;;;
;;; 参数所要删除的子图元名称
;;;
;;; 示例 (ax:DeleteObjectFromBlock (car (nentsel)))
;;;
;;; 注意大家知道，可以使用NENTSEL函数获取图块中图元的名称。
;;; 在重新生成图形前现有的图块参照不能显示更改内容。
(defun ax:DeleteObjectFromBlock (ent / doc blk)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
ent (vlax-ename->vla-object ent)
blk (vla-ObjectIdToObject doc (vla-get-OwnerID ent))
)
(vla-Delete ent)
(vla-get-Count blk)
)
(defun ax:collection->list (co / item result)
(vlax-for item co
(if (vlax-property-available-p item 'Name)
(setq result (cons (vla-get-name item) result))
) ;_ end of if
) ;_ end of vlax-for
result
) ;_ end of defun

;;;转换一个AutoLISP点到一个二维ActiveX点 
(defun ax:2DPoint (pt) 
  (vlax-make-variant 
    (vlax-safearray-fill 
      (vlax-make-safearray vlax-vbdouble '(0 . 1)) 
      (list (car pt) (cadr pt)) 
    ) 
  ) 
) 
;;;返回一个单独图元的范围 
(defun ax:GetBoundingBox (ent / ll ur) 
  (vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur) 
  (mapcar 'vlax-safearray->list (list ll ur)) 
) 
;;;由ActiveX变体返回LISP值 
;;;=================================================== 
;;;Copyright 2002 Vladimir Nesterovsky 
;;;=================================================== 
;;;第一版 
;;;This previous versions weren't working with empty 
;;;(defun lisp-value (v) 
;;;  (cond 
;;;    ((= (type v) 'variant) 
;;;     (lisp-value (vlax-variant-value v)) 
;;;    ) 
;;;    ((= (type v) 'safearray) 
;;;     (mapcar 'lisp-value (vlax-safearray->list v)) 
;;;    ) 
;;;    (T v) 
;;;  ) 
;;;) 
;;;================================================ 
;;;第二版 
;;;The previous versions weren't working with empty 
;;;safearrays. This version seems to be better: 
(defun ax:lispValue (v) 
  (cond 
    ((= (type v) 'variant) 
     (ax:lispValue (variant-value v)) 
    ) 
    ((= (type v) 'safearray) 
     (mapcar 'ax:lispValue (safearray-value v)) 
    ) 
    (T v) 
  ) 
) 
;;;================================================ 
;;;Maybe its better to just write a fully recursive solution: 
;;;第版 
;;;作者：Vladimir Nesterovsky 
;;;(defun ax:lispValue (var / vt) 
;;;  (cond 
;;;    ((/= (type var) 'variant) var) 
;;;    ((zerop 
;;;       (logand (setq vt (vlax-variant-type var)) vlax-vbarray) 
;;;     ) 
;;;     (vlax-variant-value var) 
;;;    ) 
;;;    ((zerop (logand vt vlax-vbvariant)) 
;;;     (vlax-safearray->list (vlax-variant-value var)) 
;;;    ) 
;;;    (t 
;;;     (mapcar 'ax:lispValue 
;;;      (vlax-safearray->list 
;;;        (vlax-variant-value var) 
;;;      ) 
;;;     ) 
;;;    ) 
;;;  ) 
;;;) 
 
;;;转换列表为ActiveX变体数组 
;;; 
;;;功能 
;;; 
;;;转换列表为ActiveX变体数组 
;;; 
;;;参数 
;;; 
;;;lst: 列表。该列表可以有一层的嵌套深度。如(list "1" 2 (list 1.0 2.0 3.0)) 
;;;varType: SafeArray 的类型。 
;;; 
;;;返回值 
;;; 
;;;变体数组 
;;; 
;;;示例 
;;; 
;;;(listToVariantArray (list (list 2.0 3.0 0.0) 1 2.0 "String") vlax-vbVariant) 
;;; 
;;;注意 
;;; 
;;;如果列表中有不同的数据类型，可传递vlax-vbVariant给varType参数。 
;;;要转换点列表到ActiveX坐标，可以这样写： 
;;;(list->VariantArray (apply 'append ptlist) vlax-vbDouble) 
(defun list->VariantArray (lst varType) 
  (vlax-make-variant 
    (vlax-safearray-fill 
      (vlax-make-safearray varType (cons 0 (1- (length lst)))) 
      (mapcar 
 '(lambda (x) 
    (cond ((= (type x) 'list) 
    (vlax-safearray-fill 
      (vlax-make-safearray 
        (if (apply '= (mapcar 'type x)) 
   (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 x))) 
      ) 
      x 
    ) 
   ) 
   ((= (type x) 'ename) 
    (vlax-ename->vla-object x) 
   ) 
   (t x) 
    ) 
  ) 
 lst 
      ) 
    ) 
  ) 
) 
   
(defun ax:AXValue (var / vt) 
  (cond 
    ((= (type var) 'ename) (vlax-ename->vla-object var)) 
    ((= (type var) 'list) 
     (list->VariantArray var vlax-vbVariant)) 
    ('T var) 
  ) 
) 
;;;(setq *acad-object* nil)      ; Initialize global variable 
(defun acad-object () 
  (cond (*acad-object*)   ; Return the cached object 
 (t 
  (setq *acad-object* (vlax-get-acad-object)) 
 ) 
  ) 
) 
;;;(setq *active-document* nil)  ; Initialize global variable 
(defun active-document () 
  (cond (*active-document*)  ; Return the cached object 
 (t 
  (setq *active-document* (vla-get-activedocument (acad-object))) 
 ) 
  ) 
) 
;;;(setq *model-space* nil)      ; Initialize global variable 
(defun model-space () 
  (cond (*model-space*)   ; Return the cached object 
 (t 
  (setq *model-space* (vla-get-modelspace (active-document))) 
 ) 
  ) 
) 
;;;用法： 
;;;_$  (ax:get-property (list (acad-object) "activedocument" "activelayer" "name")) 
;;;"0" 
;;;_$  (ax:get-property (list (acad-object) 'activedocument 'activelayer 'name)) 
;;;"0" 
;;;_$ (ax:get-property (list (entlast) 'layer)) 
;;;"0" 
;;;_$ (ax:get-property (list (entlast) 'color)) 
;;;256 
;;;_$ (ax:get-property (list (entlast) 'objectname)) 
;;;"AcDbPolyline" 
;;;允许第一项是entity name 
(defun ax:get-property (PropertyPathList / root obj) 
  (setq root   (car PropertyPathList) 
 propertyPathList (cdr PropertyPathList) 
  ) 
  (if (= (type root) 'ename) (setq root (vlax-ename->vla-object root))) 
  (foreach obj PropertyPathList 
    (setq root (vlax-get-property root obj)) 
  ) 
  root 
) 
;;;_$ (setq e (ax:invoke-method (list (active-document) 'modelspace 'addcircle) (list (vlax-3d-point '(3 0)) 500))) 
;;;#<VLA-OBJECT IAcadCircle 0103faa4> 
(defun ax:invoke-method (MethodPathList ParamList / root method obj) 
  (setq MethodPathList (reverse MethodPathList) 
 method        (car methodPathList) 
 methodPathList (cdr MethodPathList) 
 root (ax:get-property (reverse MethodPathList)) 
  ) 
  (apply 'vlax-invoke-method 
  (cons root (cons method paramlist)) 
  ) 
) 
;;;_$ (ax:put-property (list (entlast) 'color) 2) 
;;;nil 
(defun ax:Put-Property (PropertyPathList value / root Prop obj) 
  (setq PropertyPathList (reverse PropertyPathList) 
 Prop        (car PropertyPathList) 
 PropertyPathList (cdr PropertyPathList) 
 root (ax:get-property (reverse PropertyPathList)) 
  ) 
  (vlax-put-property root prop value) 
) 
;;; 转换选择集为变体数组 
;;; 
;;; 功能 返回一个由选择集内容填满的子对象的变体数组。 
;;; 
;;; 参数 ss: 选择集 
;;; 
;;; 返回值 变体数组 
;;; 
;;; 示例 (selectionsetToArray mySS) 
;;; 
;;; 注意 使用该函数可以将选择集转换为数组传递给ActiveX函数。 
;;; 如果需要其它的子类型，只需更改引用vlax-vbObject。 
(defun selectionset->Array (ss / c r) 
  (vl-load-com) 
  (setq c -1) 
  (repeat (fix (sslength ss)) (setq r (cons (ssname ss (setq c (1+ c))) r))) 
  (setq r (reverse r)) 
  (vlax-safearray-fill 
    (vlax-make-safearray vlax-vbObject (cons 0 (1- (length r)))) 
    (mapcar 'vlax-ename->vla-object r) 
  ) 
) 
;;; 将对象选择集添加到现有的图块定义中 
;;; 
;;; 功能 将对象选择集添加到现有的图块定义中 
;;; 
;;; 参数 一个图块插入的图元名称和一个包含要添加的对象的选择集 
;;; 
;;; 示例 (ax:AddObjectsToBlock (car (entsel)) (ssget)) 
;;; 
;;; 注意 在重新生成图形前现有的图块参照将不会显示更改内容 
(defun ax:AddObjectsToBlock (blk ss / doc blkref blkdef inspt refpt) 
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)) 
 blkref (vlax-ename->vla-object blk) 
 blkdef (vla-Item (vla-get-Blocks doc) (vla-get-Name blkref)) 
 inspt (vlax-variant-value (vla-get-InsertionPoint blkref)) 
 ssarray (selectionset->array ss) 
 refpt (vlax-3d-point '(0 0 0)) 
  ) 
  (if (not (equal inspt refpt)) 
    (foreach ent (vlax-safearray->list ssarray) (vla-Move ent inspt refpt)) 
  ) 
  (vla-CopyObjects doc ssarray blkdef) 
  (foreach ent (vlax-safearray->list ssarray) (vla-Delete ent)) 
  (princ) 
) 
;;; 从图块定义中删除指定的子图元并返回在图块定义中所剩下的项目数 
;;;   
;;; 功能 从图块定义中删除指定的子图元并返回在图块定义中所剩下的项目数 
;;; 
;;; 参数 所要删除的子图元名称 
;;; 
;;; 示例 (ax:DeleteObjectFromBlock (car (nentsel))) 
;;; 
;;; 注意 大家知道，可以使用NENTSEL函数获取图块中图元的名称。 
;;; 在重新生成图形前现有的图块参照不能显示更改内容。 
(defun ax:DeleteObjectFromBlock (ent / doc blk) 
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)) 
 ent (vlax-ename->vla-object ent) 
 blk (vla-ObjectIdToObject doc (vla-get-OwnerID ent)) 
  ) 
  (vla-Delete ent) 
  (vla-get-Count blk) 
) 
(defun ax:collection->list (co / item result) 
  (vlax-for item co 
    (if (vlax-property-available-p item 'Name) 
      (setq result (cons (vla-get-name item) result)) 
    ) ;_ end of if 
  ) ;_ end of vlax-for 
  result 
) ;_ end of defun

GTJ116600 · 发表于 2013-7-31 10:30:15

好好，谢谢分享

阿凯 · 发表于 2013-11-23 07:51:41

学习VL。LISP的水平停留于AutoLISP，快十年没编程了，甚至VL命令都没学，打开自己的编写程序，发现几乎都是2004年前的版本，连排序都是自己编的......再不学真的OUT了

434939575 · 发表于 2014-3-23 22:17:15

最喜欢通用函数了！谢谢。

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

[他山之石] 几个 ax:XXX 函数

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

评分