快速建有比例的视口

00放飞梦想00

  此代码出自明经网，哪位大神帮忙完善，谢谢！


      功能1：在布局空间返回模型空间框选图形，然后返回布局空间，输比例，左下角基点插入，循环新建锁定视口
     功能2：在布局空间框选任意小大矩形框返回模型空间框选图形（附带布局空间矩形框图建视口），然后返回布局空间，输比例，左下角基点插入，                循环新建视口，新建视口为锁定，视口锁定下，调节移动视口内图形
     功能3：大小视口重叠情况视口相互切换，可增加视口图层功能

(defun c:VR        ()
  (setvar "DYNMODE" 3)
  (setvar "cmdecho" 0)
  (setq LAY (getvar "CLAYER"))
  (setq os (getvar "OSMODE"))
  (setq olderr *error*)                        ;保存原有*erroer*函数内容
  (defun *error* (msg)                        ;自定义出错处理
    (COMMAND "CLAYER" LAY)
    (setq *error* olderr)
    (princ errn)
  )
  (if (= scaa nil)
    (setq scaa "100")
  )
  (if (= 1 (getvar "TILEMODE"))
    (progn
      (setq err_old *error*
            *error* err_new
      ) ;_ end of setq
      (setvar "OSMODE" 0)
      (command "model")
      (princ "\n请点取需要出图范围第一角点:\n")
      (setq FP (getpoint))
      (setq SP (getcorner FP "\n请点取出图范围另一角点:\n"))
      (setq HT (abs (- (cadr sp) (cadr fp))))
      (setq WD (abs (- (car sp) (car fp))))
      (COMMAND "CLAYER" LAY)
      (setvar "OSMODE" os)
      (setq *error* olderr)                ;恢复原有*error*函数内容
      (COMMAND "CLAYER" LAY)
      (setvar "OSMODE" os)
      (setvar "TILEMODE" 0)
      (princ
        "\n\n\n★★注意：\n\n若现在不是您要创建视口的布局空间，请结束此命令，\n并手动切换至要要创建视口的布局重新运行本命令。\n\n"
      )
      (c:VR)
    )
    (progn
      (if (or (null fp) (null sp))
        (progn
          (alert "\n程序将切换至【模型空间】设置视口显示区域!")
          (princ
            "
      \n程序将切换至【模型空间】设置视口显示区域!"
          )
          (setvar "TILEMODE" 1)
          (c:VR)
        )
        (progn
          (command "PSPACE")
          (setq        sca
                 (getstring
                   (strcat
                     "\n请输入出图比例【 1∶？】<"
                     scaa
                     ">:\n\n\n★★注意：\n\n若现在不是您要创建视口的布局空间，请结束此命令，\n并手动切换至要要创建视口的布局重新运行本命令。"
                   )
                 )
          )
          (if (= sca "")
            (setq sca scaa)
          ) ;_ end of if
          (setq scaa sca)
          (setq scal (atoi (substr sca 1)))
          (princ "\n请点取图的左下角点\n\n")
          (setq BLP (getpoint))
          (setq        TRP (list (+ (car BLP) (/ Wd scal))
                          (+ (cadr BLP) (/ HT scal))
                          0
                    ) ;_ end of list
          ) ;_ end of setq
          (command "_zoom" BLP TRP)
          (command "_mview" BLP TRP)
          (command "_mspace")
          (command "_zoom" fp sp)
          (command "_zoom" (strcat "1/" sca "xp"))
          (command "_pspace")
          (command "_zoom" "e")
          (command "mview" "l" "on" "c" BLP TRP "")
          (COMMAND "LAYER" "M" "Defpoints" "C" "135" "" "")
          (command "change" BLP "" "p" "la" "Defpoints" "")
          (setq blp nil)
        )
      )
    )
  )                                        ;end if
  (COMMAND "CLAYER" LAY)
  (setvar "OSMODE" os)
  (setq *error* olderr)                        ;恢复原有*error*函数内容
  (COMMAND "CLAYER" LAY)
  (setvar "OSMODE" os)
  (princ)
)

stonedesign

你不是有源码了

00放飞梦想00

stonedesign 发表于 2020-4-1 20:41
你不是有源码了

这个源码达不到那个效果

00放飞梦想00

stonedesign 发表于 2020-4-1 20:41
你不是有源码了

目前一个布局只能建一个视口，需要帮忙修改