明经CAD社区

 找回密码
 注册

扫一扫,访问微社区

QQ登录

只需一步,快速开始

查看: 1664|回复: 13

求一个不等比缩放的lISP程序,不用输入比例因子,直接输入X. Y缩放的尺寸就好

[复制链接]
发表于 2015-10-20 09:59 | 显示全部楼层 |阅读模式
1明经币

发表于 2015-10-22 13:21 | 显示全部楼层
;x,y方向不同比例缩放
; ***  XSCALE   [Version 1.0] 6/22/2005  ***
;
;Copyleft Gu Wenwei
;
; ***************************************
; ****  Author:  Apooollo            ****
; ****                               ****
; ****  Wuxi Jiangsu China           ****
; ***************************************
;
;
; This program takes selected objects, defines an anonymous block,
; then inserts the block at the original location, Scale by X,Y


(defun C:XSCALE(/ bp ss xscal yscal entL)

  (defun errexit (s)
    (princ "\nError:  ")
    (princ s)
    (restore)
  )

  (defun restore ()
    (setvar "CMDECHO" (car oldvar))
    (setq *error* olderr)
    (princ)
  )
  
(defun MAKEUNBLOCK (ss ip / tmp errexit mbx BLAYER)

  (setq T (not nil))
  (setq olderr  *error*
        *error* errexit
  )
  (setq oldvar
    (list
      (getvar "CMDECHO")
    )
  )
  (setvar "CMDECHO" 0)
  (terpri)
  (if BLAYER  
    (command "._LAYER"
      (if (tblsearch "LAYER" BLAYER) "_S" "_M")
      BLAYER
      ""
    )
  )
  (if (and ip ss)
    (progn
      (entmake (list
        (cons '0 "BLOCK")
        (cons '2 "*U")
        (cons '70 1)
        (cons '10 ip)
      ))
      (setq cnt (sslength ss))
      (while (>= (setq cnt (1- cnt)) 0)
        (setq tmp (ssname ss cnt))
        (entmake (setq el (entget tmp)))
        (if (> (cdr (assoc 66 el)) 0)
          (while
            (/= "SEQEND"
              (cdr
                (assoc 0
                  (entmake (setq el (entget (entnext (cdr (assoc -1 el))))))
                )
              )
            )
          )
        )
        (entdel tmp)
      )
      (setq tmp (entmake (list (cons '0 "ENDBLK"))))
      (entmake (list
        (cons '0 "INSERT")
        (cons '2 tmp)
        (cons '10 ip)
      ))
    )
  )  
  (restore)
)

  (setq ss (ssget))    ;;; 选择缩放实体
  (if ss
    (progn
      (setvar "cmdecho" 0)
      (setq bp (getpoint "缩放基准点 (<0,0,0>): "))
      (if (not bp) (setq bp (list 0 0 0)))
      (setq xscal (getreal "X向比例因子 <1>: "))
      (if (not xscal) (setq xscal 1))
      (setq yscal (getreal "Y向比例因子 <1>: "))
      (if (not yscal) (setq yscal 1))
      (MAKEUNBLOCK ss bp)
      (setq entL (entget (entLast))
          entL (subst (cons 41 xscal) (assoc 41 entL) entL)
          entL (subst (cons 42 yscal) (assoc 42 entL) entL)
      )
      (entmod entL)
      (command "_explode" "l" "")
    )
  )
  (princ "X,Y不同比例缩放, 命令:XSCALE")
)
回复

使用道具 举报

 楼主| 发表于 2015-10-22 21:31 | 显示全部楼层
本帖最后由 龙吟小调 于 2015-10-22 21:33 编辑
zjy2999 发表于 2015-10-22 13:21
;x,y方向不同比例缩放
; ***  XSCALE   [Version 1.0] 6/22/2005  ***
;

这程序试用了下,还是要输入X,Y比例因子才行。我想找的是输入命令,指定基点,再输入X,Y的尺寸就可以的程序。记得原来论坛好像有的,当时也下过就是丢失了找不到了。
回复

使用道具 举报

发表于 2016-3-12 02:37 | 显示全部楼层
看看是不是这样的

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
回复

使用道具 举报

 楼主| 发表于 2016-3-21 21:17 | 显示全部楼层
本帖最后由 龙吟小调 于 2016-3-21 21:19 编辑
laorenhao999 发表于 2016-3-12 02:37
看看是不是这样的


就是这个终于找到了,以前有过的丢了,很久没来了竟然一来就有收获
回复

使用道具 举报

发表于 2016-7-2 16:32 | 显示全部楼层
是很强大,但感觉不如动态块好用吧。可能用到的范围不一样!
回复

使用道具 举报

发表于 2017-11-3 08:40 | 显示全部楼层
回帖是一种美德!感谢楼主的无私分享 谢谢
回复

使用道具 举报

发表于 2017-12-13 18:15 | 显示全部楼层
感谢楼主的无私分享 正需要 谢谢!
回复

使用道具 举报

 楼主| 发表于 2017-12-15 16:39 | 显示全部楼层
(defun C:xysc (/ bp ss xscal yscal entL)
  (setvar "qaflags" 0)
  (defun errexit (s)
    (princ "\nError:  ")
    (princ s)
    (restore)
  )

  (defun restore ()
    (setvar "CMDECHO" (car oldvar))
    (setq *error* olderr)
    (princ)
  )

  (defun MAKEUNBLOCK (ss ip / tmp errexit mbx BLAYER)
    (setq olderr  *error*
          *error* errexit
    )
    (setq oldvar (list (getvar "CMDECHO")))
    (setvar "CMDECHO" 0)
    (terpri)
    (if        BLAYER
      (command "._LAYER"
               (if (tblsearch "LAYER" BLAYER)
                 "_S"
                 "_M"
               )
               BLAYER
               ""
      )
    )
    (if        (and
          ip
          ss
        )
      (progn
        (entmake (list (cons '0 "BLOCK")
                       (cons '2 "*U")
                       (cons '70 1)
                       (cons '10 ip)
                 )
        )
        (setq cnt (sslength ss))
        (while (>= (setq cnt (1- cnt))
                   0
               )
          (setq tmp (ssname ss cnt))
          (entmake (setq el (entget tmp)))
          (if (> (cdr (assoc 66 el)) 0)
            (while (/= "SEQEND"
                       (cdr (assoc 0
                                   (entmake (setq el
                                                   (entget
                                                     (entnext
                                                       (cdr
                                                         (assoc -1 el)
                                                       )
                                                     )
                                                   )
                                            )
                                   )
                            )
                       )
                   )
            )
          )
          (entdel tmp)
        )
        (setq tmp (entmake (list (cons '0 "ENDBLK"))))
        (entmake
          (list (cons '0 "INSERT") (cons '2 tmp) (cons '10 ip))
        )
      )
    )
    (restore)
  )
  (setq ss (cadr (ssgetfirst)))
  (while (= ss nil)
    (setq ss (ssget))                        ; 选择缩放实体
  )
  (setq        i 0
        dwcorn nil
        upcorn nil
  )
  (repeat (sslength ss)
    (setq ent (ssname ss i))
    (setq obj (vlax-ename->vla-object ent))
    (vla-GetBoundingBox obj 'pta 'ptb)
    (setq dwcorn (cons (vlax-safearray->list pta) dwcorn))
    (setq upcorn (cons (vlax-safearray->list ptb) upcorn))
    (setq i (1+ i))
  )
  (setq        ptlist (append
                 dwcorn
                 upcorn
               )
  )
  (setq        x (mapcar
            'car
            ptlist
          )
  )
  (setq        y (mapcar
            'cadr
            ptlist
          )
  )
  (setq        x1 (apply
             'min
             x
           )
  )
  (setq        y1 (apply
             'min
             y
           )
  )
  (setq        x2 (apply
             'max
             x
           )
  )
  (setq        y2 (apply
             'max
             y
           )
  )
  (setq xx (- (car (list x2 y2)) (car (list x1 y1))))
  (setq yy (- (cadr (list x2 y2)) (cadr (list x1 y1))))
  (if ss
    (progn
      (setq bp (polar (list x1 y1)
                      (angle (list x1 y1) (list x2 y2))
                      (/ (distance (list x1 y1) (list x2 y2)) 2)
               )
      )
      (setq xx1 (getdist "\n指定新的X方向尺寸:"))
      (setq yy1 (getdist "\n指定新的Y方向尺寸:"))

      (setq xscal (/ xx1 xx))
      (setq yscal (/ yy1 yy))
      (MAKEUNBLOCK ss bp)
      (setq entL (entget (entLast))
            entL (subst
                   (cons 41 xscal)
                   (assoc 41 entL)
                   entL
                 )
            entL (subst
                   (cons 42 yscal)
                   (assoc 42 entL)
                   entL
                 )
      )
      (entmod entL)
      (command "_explode" "l")
    )
  )
  (princ)
)
回复

使用道具 举报

 楼主| 发表于 2017-12-15 16:40 | 显示全部楼层
htlaser 发表于 2017-12-13 18:15
感谢楼主的无私分享 正需要 谢谢!

不知道发的对不对,自己复制保存下
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号  
©2000-2017 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2018-10-18 01:04 , Processed in 0.254000 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.3

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表