李麦克的一个图元齐线程序，有点小问题待处理

半听可乐

一个图元动态对齐直线、曲线的工具，在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 [O]ffset, [P]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 '(43  61)) (setq *oa|off (+ *oa|off 0.1))
                  )
                  ( (member g2 '(45  95)) (setq *oa|off (- *oa|off 0.1))
                  )
                  ( (member g2 '(80 112)) (setq *oa|per (- (/ pi 2.) *oa|per))
                  )                                          
                  ( (member g2 '(13  32)) 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-delete  bo)
        (vla-delete  bd)
      )
    )
  )
  (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                        ;;
;;------------------------------------------------------------;;

liuyj

你这个版本也老了，我这里有新版本，经我改造了一下，应该没有什么问题了。http://bbs.mjtd.com/forum.php?mo ... id=99884&extra=

xiabin68

顶一个，，这是一个好东西，，学习了，，，

liuyj

在cad2004~2006(R16)下，vla-explode是有问题的，改成(command ".explode" (entlast))

半听可乐

liuyj 发表于 2013-1-1 23:02
在cad2004~2006(R16)下，vla-explode是有问题的，改成(command ".explode" (entlast))

我把“vla-explode”替换成“(command ".explode" (entlast))”后程序目的是实现了，但是为什么会出现下面的提示？：

** Error: no function definition: nil **