[LISP程序]：拉伸实体及与之相连实体的顶点

wkai

好久没有写程序了，这个可以替换系统得stretch命令。
如果点选物体的话则可以移动该物体，同时拉伸和它公用顶点的实体。
如果框选 则进行正常的strech
[php]
(defun c:s (/ ptlst E ENT N P0 P1 PAUSE SS)
  (setq ent (entsel))
  (if ent
    (progn
      (command "._undo" "be")
      (if (setq ss (ssget '((0 . "*line,arc"))))
      (setq ss (ssadd (car ent) ss))
        (setq ss (ssadd (car ent) ))
        )
      (setq p0 (getpoint "\n拉伸起点:"))
      (repeat (setq n (sslength ss))
        (setq e (vlax-ename->vla-object (ssname ss (setq n (1- n)))))
        (setq ptlst (cons (vlax-curve-getEndPoint e) ptlst))
        (setq ptlst (cons (vlax-curve-getstartPoint e) ptlst))
      )
      (command "._move" ss "" p0)
      (while (/= 0 (getvar "cmdactive"))
        (command pause)
      )
      (setq p1 (getvar "lastpoint"))
      (print ptlst)
      (command "._stretch")
      (foreach n ptlst
        (command "c"
                 (polar n (/ pi 4) (/ (getvar "viewsize") 5000))
                 (polar n (/ pi 1.25) (/ (getvar "viewsize") 5000))
        )
      )
      (command "r")
      (repeat (setq n (sslength ss))
        (setq e (ssname ss (setq n (1- n))))
        (command e)
      )
      (command "" "non" p0 "non" p1)
      (while (/= 0 (getvar "cmdactive"))
        (command pause)
      )
      (command "._undo" "e")
    )
    (command "._stretch")
  )
  (princ)
)
[/php]

lxyljl

好象不怎么行哦~~使用不出其功能