[LISP程序]：非常好用的COPY和OFFSET新物体使之到当前层!

jeepsheep

求COPY和OFFSET新物体使之到当前层!

例如画室内的家具时(当前层为家具层),我OFFSET墙线600作为柜的边线,想新物体(在墙的层)直接为当前层:家具层.

谢谢!

lsjjm

REFER TO:
[php]
(defun c:test ()
  (vl-load-com)
  (vl-cmdf "copy" pause pause  pause pause)
  (setq obj (vlax-ename->vla-object (entlast)))
  (vla-put-layer obj (getvar "clayer"))
)
[/php]

jeepsheep

谢谢lsjjm !非常好用!
能否再写个OFFSET的!我不会编程,想改都不会改,惭愧!

xiaolizilili

请详细说明一下具体加载的过程，看看我有没有错误

pfrynwgkq

最初由 jeepsheep 发布
[B]求COPY和OFFSET新物体使之到当前层!

例如画室内的家具时(当前层为家具层),我OFFSET墙线600作为柜的边线,想新物体(在墙的层)直接为当前层:家具层.

谢谢! [/B]

(defun c:OL( / ent ents)
  (setvar "cmdecho" 1)
  (setq ent (entlast))
  (command "_.offset" pause)
  (while (= (getvar "cmdactive") 1)
    (command pause)
    (if (not (equal ent (entlast)))
      (progn
(setq ents (entget (entlast)))
(setq ents (subst (cons 8 (getvar "clayer")) (assoc 8 ents) ents))
(entmod ents)
      )
    )
  )
  (princ)
)
这个好一些。不会出那么多错误。是明经的一位大哥偏的。


通过工具菜单->加载应用程序 offset.lps文件，如需要每次启动时均加载该程序，则可以将该文件放在启动组中。
输入：OL
就可以用这个命令啦。

andyhua5240

谢谢楼主，程序非常的好用！

zk_hisen

蛮实用的，收下了。

cuiwenjun2008

太感谢了，我总是偏移道路中心线一定距离，后改偏移后的线到路边线层，这下可好了，是在太方便了。
顺便问一下，不是还有copy的lisp吗，怎么没有，希望楼主上传！

jeepsheep

再给大家一个好用的LISP
;输入距离直接变双线
(defun c:xx( / ent dis)
  (setq ent (car (entsel)))
  (setq dis (getreal "\n输入距离:"))
  (vla-offset (vlax-ename->vla-object ent) (/ dis 2.0))
  (vla-offset (vlax-ename->vla-object ent) (- (/ dis 2.0)))
  (entdel ent)
  (princ)
)  

这是我上网求的,画图特方便,能直接输入距离就直接变这个宽度的双线!

;clone.lsp
;复制所选对象到另一个层，不移动其原始位置。

(defun C:CF( / s l)
  (setvar "cmdecho" 0)
  (if
    (and
      (setq s (ssget))
      (not (zerop (sslength s)))
      (not (zerop (strlen (setq l (getstring "\n要复制到的层： "))))))
    (command "copy" s "" "@" "@" "change" s "" "p" "la" l "")
    (prompt "Invalid."))
  (progn)
)


; copylay.lsp
; 复制到当前层（copy_to_layer）。
;本程序将复制一个实体到当前层无论它在哪个层。

(defun C:cpc ()
    (setvar "cmdecho" 0)
    (setq c_layer (getvar "clayer")
          sset (ssget)
          pt1 (getpoint "\n基点： ")
          count 0)
   (prompt "\n位移的第二点： ")
      (setq  len (sslength sset))
      (while (< count len)
       (setq name (ssname sset count)
             ptlst (entget name)
             b (assoc 8 ptlst)
             b1 (cdr (assoc 8 ptlst))
             c (cons 8 c_layer)
             d (subst c b ptlst)
             count (1+ count))
            (entmod d)
     )
    (command "_copy" sset "" pt1 pause)
    (setq count 0)
    (while (< count len)
    (setq name (ssname sset count)
             ptlst (entget name)
             b (assoc 8 ptlst)
             c (cons 8 b1)
             d (subst c b ptlst)
             count (1+ count))
            (entmod d)
     )
     (princ)
   )
我这有两个LISP,能否帮忙改改,让它们合并成:拷贝物体到当前层,不移动其原始位置。或者改第一个LISP,使的选层时能跳出选层的对话框(选项有:选当前层,选层列表中的任意层),免得有的层名太长不好记!

DDG

好用!感觉楼主是做室内设计的吧!同行!
我看了签名的链接,好多多跟室内设计制图有关,很方便!
谢谢楼主,希望还有更好的跟大家分享!

zengwei104

太好了，再也不用不停的改变图层了

大尾巴狼

最初由 jeepsheep 发布
[B]再给大家一个好用的LISP
;输入距离直接变双线
(defun c:xx( / ent dis)
  (setq ent (car (entsel)))
  (setq dis (getreal "\n输入距离:"))
  (vla-offset (vlax-ename->vla-object ent) (/ dis 2.0))
  (vla... [/B]

这个 复制物体到当前层绘出错，
如你复制一个1层物体到当前2层，再选择1层的物体与2层的物体，再复制，看看有什么后果？

另外偏移线到当前层，ET扩展工具里有，只是多了选项，设过一次就好了

jjss

太好了，再也不用不停的改变图层了

czad

9楼的：copylay.lsp
非常好用，但是框选物体复制后会出现被选物体的图层也改变的现象。

自由的鱼

试试我的偏移程序，支持比例尺，程序见下面的地址！