李麦克的一个图元齐线程序，有点小问题待处理
一个图元动态对齐直线、曲线的工具，在CAD2004中无法将移动位置后的图元保留下来，是怎么回事呢？CAD2008正常。;;--------------------=={ Object Align }==--------------------;;
;; ;;
;;Prompts for a selection of objects to dynamically align ;;
;;with a selected curve. ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;Version 1.1 - 07-05-2011 ;;
;;------------------------------------------------------------;;
(defun c:oA nil (c:ObjAlign))
(defun c:ObjAlign
( /
*error*
_getitem
_getuniquekey
_listboundingbox
_select
_ss->list
a1 a2 acblk acdoc acspc
bb bd bn bo bs
di
en
g1 g2 gr
ms
of
pt
ss
)
;;------------------------------------------------------------;;
(defun *error* ( msg )
(if (and bo (not (vlax-erased-p bo))) (vla-delete bo))
(if (and bd (not (vlax-erased-p bd))) (vla-delete bd))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
;;------------------------------------------------------------;;
(defun _ss->list ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
)
)
;;------------------------------------------------------------;;
(defun _GetItem ( collection item )
(if
(not
(vl-catch-all-error-p
(setq item
(vl-catch-all-apply 'vla-item (list collection item))
)
)
)
item
)
)
;;------------------------------------------------------------;;
(defun _GetUniqueKey ( collection seed / key i ) (setq i 0)
(while
(_GetItem collection
(setq key
(strcat seed (itoa (setq i (1+ i))))
)
)
)
key
)
;;------------------------------------------------------------;;
(defun _ListBoundingBox ( lst / a b l x )
(while (setq x (car lst))
(if (vlax-method-applicable-p x 'GetBoundingBox)
(progn
(vla-getboundingbox x 'a 'b)
(setq l (cons (vlax-safearray->list a) (cons (vlax-safearray->list b) l)))
)
)
(setq lst (cdr lst))
)
(mapcar '(lambda ( x ) (apply 'mapcar (cons x l))) '(min max))
)
;;------------------------------------------------------------;;
(defun _Select ( msg pred func / e ) (setq pred (eval pred))
(while
(progn (setvar 'ERRNO 0) (setq e (car (func msg)))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\n** Missed, Try again **")
)
( (eq 'ENAME (type e))
(if (and pred (not (pred e)))
(princ "\n** Invalid Object Selected **")
)
)
)
)
)
e
)
;;------------------------------------------------------------;;
(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace))
acblk (vla-get-blocks acdoc)
)
(or *oa|per (setq *oa|per (/ pi 2.)))
(or *oa|off (setq *oa|off 0.))
(if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar 'CLAYER))))))
(princ "\n--> Current Layer Locked.")
(if
(and (setq ss (_ss->list (ssget "_:L" '((0 . "~VIEWPORT")))))
(progn
(setq bs (getpoint "\nSpecify Base Point <Center>: "))
(setq bb (_ListBoundingBox ss))
)
(setq en
(_Select "\nSelect Curve: "
'(lambda ( x )
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vlax-curve-getendparam (list x))
)
)
)
entsel
)
)
)
(progn
(vla-copyobjects acdoc
(vlax-make-variant
(vlax-safearray-fill (vlax-make-safearray vlax-vbobject (cons 0 (1- (length ss)))) ss)
)
(setq bd
(vla-add acblk
(vlax-3D-point
(cond ( bs ) ( (apply 'mapcar (cons '(lambda ( a b ) (/ (+ a b) 2.)) bb)) ))
)
(setq bn (_GetUniqueKey acblk "Temp"))
)
)
)
(setq bo (vla-insertblock acspc (vlax-3D-point (getvar 'VIEWCTR)) bn 1. 1. 1. 0.)
of (/ (- (cadadr bb) (cadar bb)) 2.)
ms (princ "\n[+/-] for ffset, erpendicularity toggle, <Exit>")
)
(while
(progn (setq gr (grread 't 15 0) g1 (car gr) g2 (cadr gr))
(cond
( (member g1 '(5 3))
(setq pt (vlax-curve-getClosestPointto en (setq g2 (trans g2 1 0)))
a1 (angle pt g2)
a2 (+ a1 *oa|per)
)
(vla-put-InsertionPoint bo (vlax-3D-point (polar pt a1 (* of *oa|off))))
(vla-put-Rotation bo a2)
(= 5 g1)
)
( (= 2 g1)
(cond
( (member g2 '(4361)) (setq *oa|off (+ *oa|off 0.1))
)
( (member g2 '(4595)) (setq *oa|off (- *oa|off 0.1))
)
( (member g2 '(80 112)) (setq *oa|per (- (/ pi 2.) *oa|per))
)
( (member g2 '(1332)) nil
)
( (member g2 '(79 111))
(setq *oa|off
(/
(cond
( (getdist (strcat "\nSpecify Offset <" (rtos (* of *oa|off)) ">: ")))
( (* of *oa|off) )
)
of
)
)
(princ ms)
)
( t )
)
)
( (= 25 g1) nil
)
( t )
)
)
)
(vla-explode bo)
(vla-deletebo)
(vla-deletebd)
)
)
)
(princ)
)
;;------------------------------------------------------------;;
(vl-load-com) (princ)
(princ "\n:: ObjectAlign.lsp | Version 1.1 | ?Lee Mac 2011 www.lee-mac.com ::")
(princ "\n:: Type \"ObjAlign\" or \"OA\" to Invoke ::")
(princ)
;;------------------------------------------------------------;;
;; End of File ;;
;;------------------------------------------------------------;;
你这个版本也老了，我这里有新版本，经我改造了一下，应该没有什么问题了。http://bbs.mjtd.com/forum.php?mod=viewthread&tid=99884&extra= 顶一个，，这是一个好东西，，学习了，，， 在cad2004~2006(R16)下，vla-explode是有问题的，改成(command ".explode" (entlast))
本帖最后由 半听可乐 于 2013-1-1 23:15 编辑
liuyj 发表于 2013-1-1 23:02 http://bbs.mjtd.com/static/image/common/back.gif
在cad2004~2006(R16)下，vla-explode是有问题的，改成(command ".explode" (entlast))
我把“vla-explode”替换成“(command ".explode" (entlast))”后程序目的是实现了，但是为什么会出现下面的提示？：
** Error: no function definition: nil **
页:
[1]