vqrec : 布局中指定矩形视口，再连续指定切分区域---command版

masterlong

源码见2楼
顺便求一下非command程序


程序应用场景说明

图1

图2


图1中的建筑底图是厂房的屋面
实际设计内容仅楼梯间和电梯机房
椭圆圈的几个很小的区域
设计人偷懒直接套了一个A0加长图框
中间图就算了
但是正式出图肯定不能这样
现在需要把有效区域重做视口
再合并到其它平面中图2是合并后的效果


本身我编了一个程序
用于在模型绘制多个矩形直接生成视口
但是模型布局切换实在太慢了
而这个项目里这样操作的需求量是非常非常大
于是有了这样一个程序
直接在已有视口的基础上
切分出多个新视口

masterlong

;;;;;;vqrec : 布局中指定矩形视口，再连续指定切分区域
(defun c:vqrec()
(princ "\nvqrec : 布局中指定矩形视口，再连续指定切分区域")(princ)
(command "undo" "g")

(setq p1p2list NIL)
(if (and
    (setq ss (ssget ":e:s" '((0 . "VIEWPORT"))))
    (setq vpent (ssname ss 0))
    (setq vpentlist (list vpent))
    (zooment vpent 2)
    ;;获取视口的第1、3角点
    (setq vcen (dxf 10 vpent))
    (setq vhw (/ (dxf 40 vpent) 2.0))
    (setq vhh (/ (dxf 41 vpent) 2.0))
    (setq ptvp1 (list (- (car vcen) vhw) (- (cadr vcen) vhh))) ;;原视口右下点
    (setq ptvp2 (list (+ (car vcen) vhw) (+ (cadr vcen) vhh))) ;;原视口左上点
    ;;获取当前屏幕高度，取二百分之一作为框选的尺寸
    (setq size (/ (getvar "viewsize") 200.0))
    ;;获取ptvp1、ptvp2的框选点
    (setq ptvp1a (list (+ (car ptvp1) size) (+ (cadr ptvp1) size))
      ptvp1b (list (- (car ptvp1) size) (- (cadr ptvp1) size))
    )
    (setq ptvp2a (list (+ (car ptvp2) size) (+ (cadr ptvp2) size))
      ptvp2b (list (- (car ptvp2) size) (- (cadr ptvp2) size))
    )
  )
  (vqrec_getp1p2)
)

(command "undo" "e")
(princ)
)
(defun vqrec_getp1p2()
(if (and
    (setq p1 (getpoint "\n指定切分区域第1点 / <右键退出> : "))
    (setq p2 (getcorner p1 " ok   指定切分区域第2点 / <右键退出> : "))
    (princ " ok ")
   )
   (progn
    (setq p1p2list (cons (list p1 p2) p1p2list))
    (command "rectang" "non" p1 "non" p2)
    (redraw (entlast) 3)
    (setq vpentlist (cons (entlast) vpentlist))
    (vqrec_getp1p2)
   )
   (if p1p2list
    (progn
     (foreach p1p2 p1p2list
      (zooment vpent 2)
      (command "copy" vpent "" "non" "0,0" "non" "0,0")
      (redraw vpent 2)
      (setq p1 (car  p1p2))
      (setq p2 (cadr p1p2))
      
          ;;;;
          ;;;;vla方法暂时无法实现目的，尝试使用command实现视口角点的拉伸-----成功
          ;;;;
          (command "STRETCH" "c" "non" ptvp1a "non" ptvp1b "" "non" ptvp1 "non" p2)
          (command "STRETCH" "c" "non" ptvp2a "non" ptvp2b "" "non" ptvp2 "non" p1)
          (redraw vpent 1)
     )
     (foreach x vpentlist (entdel x))
     (princ "\n视口已根据指定区域切分完成")
    )
    (princ "未绘制矩形，程序结束")
   )
)
(princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--------------公共函数
;999公共函数
;;以指定图元中心缩放窗口
(defun zooment( ent sc / box x midpo h pa pb )
(vla-getboundingbox (vlax-Ename->Vla-Object ent) 'll 'ur)
(setq box (mapcar 'vlax-safearray->list (list ll ur)))
(setq midpo (getmidpo box))
(setq h (abs (- (cadr (cadr box)) (cadr (car box)))))
(setq h (* h (sqrt sc)))
;;;;(vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point pa) (vlax-3d-point pb))
(vla-ZoomCenter  (vlax-get-acad-object) (vlax-3d-point midpo) h)
box
)
;999公共函数
;;求点对中点
(defun getmidpo( pts / P1 P2 X Y )
(setq p1 (car pts) p2 (cadr pts))
(if (= (length p1) (length p2))
  nil
  (setq p1 (list (car p1) (cadr p1))
    p2 (list (car p2) (cadr p2))
  )
)
(mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2)
)
;999公共函数
;;dxf  获取图元某个dxf组码（内参不限种类顺序：：： n ent [entget ent] ）
(defun dxf( n ent / temp tmp )
(if (/= (type n) 'int)
  (setq temp  ent
    ent n  
    n  temp
  )
)
(if (= (type ent) 'ENAME)
  (setq temp (entget ent))
  (setq temp ent)
)
(if (= n 62)
  (if (setq tmp (assoc n temp))  (cdr tmp)  256)
  (cdr (assoc n temp))
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--------------公共函数

masterlong

本来想用vla函数改变视口
但是解决不了模型“视点”随视口中心“平移”的问题
无奈采用command的拉伸命令实现需求
下面是未完成的代码
期待高手完善

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--------------不能实现目标的vla代码
(defun c:vr4()
        (setq ss (ssget ":e:s" '((0 . "VIEWPORT"))))
        (setq vpent (ssname ss 0))
        (setq newobj (vlax-Ename->Vla-Object vpent))
        (setq CustomScale (vla-get-CustomScale newobj))
        (setq 12dxf (dxf 12 vpent))
       
        (setq p1 (getpoint "\n指定切分区域第1点 / <右键退出> : "))
        (setq p2 (getcorner p1 " ok   指定切分区域第2点 / <右键退出> : "))
        (princ " ok ")

        (setq pt (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2))
        (setq xdist (abs (- (car  p1) (car  p2))))
        (setq ydist (abs (- (cadr p1) (cadr p2))))
                       
        (vla-put-width newobj xdist)
        (vla-put-height newobj ydist)
        (vla-put-center newobj (vlax-3D-Point pt))
        (vla-put-CustomScale  newobj CustomScale)
       
        ;|
        ...........                ;;怎么保持模型不随视口中心“平移” ？？？？？
        |;
                                               
(princ)
)

叮咚

http://www.lee-mac.com/vpoutline.html
可以参考lee mac这个程序，先把画的矩形反到模型空间中，找到中心点。也就是下面代码的中心 vpt

1. (defun ttx(ptcen vpt ww dd ang blx)
   
2. 
   
3.   ;(setq ptcenx (mapcar '(lambda(xx)(/ xx 1.0 blx)) ptcen))
   
4.   (setq obj_mv (vlax-invoke-method aps "AddPViewport" (vlax-3D-point ptcen) (+ (/ ww blx) 0.0) (+ (/ hh blx) 0.0)))
   
5.   (vlax-put-property obj_mv "Layer" "0-视口")
   
6.   (vlax-put-property obj_mv "Color" acYellow)
   
7.   (vlax-put-property obj_mv "ViewportOn" acTrue)
   
8.   (vlax-put-property obj_mv "TwistAngle" (* -1 ang))
   
9.   (vlax-put-property obj_mv "GridOn" acFalse)
   
10.   ; ActivePViewport示例中有以下说明
    
11.   ;' 在将图纸空间 Viewport 设为活动前，mspace 属性必须为 True
    
12.   ;  ThisDrawing.mspace = True
    
13.   ;  ThisDrawing.ActivePViewport = newPViewport
    
14.   (vlax-put-property adoc_l "ActiveSpace" acPaperspace)
    
15.   (vlax-invoke-method (vlax-get-property acad_l "Application") "ZoomExtents")
    
16.   (vlax-put-property adoc_l "MSpace" acTrue)
    
17.   (vlax-put-property adoc_l "ActivePViewport" obj_mv)
    
18.   ;(vlax-put-property adoc_l "ActivePViewport" obj_mv)
    
19.   (vlax-invoke-method (vlax-get-property acad_l "Application") "ZoomCenter" (vlax-3D-point vpt) 1.0)
    
20.   (vlax-put-property adoc_l "MSpace" acFalse)
    
21.   (vlax-put-property obj_mv "CustomScale" (/ 1.0 blx))
    
22.   ;(vlax-invoke-method (vlax-get-property acad_l "Application") "ZoomPrevious")
    
23. 
    
24. )

(defun ttx(ptcen vpt ww dd ang blx)<br /> <br />   ;(setq ptcenx (mapcar '(lambda(xx)(/ xx 1.0 blx)) ptcen))<br />   (setq obj_mv (vlax-invoke-method aps "AddPViewport" (vlax-3D-point ptcen) (+ (/ ww blx) 0.0) (+ (/ hh blx) 0.0)))<br />   (vlax-put-property obj_mv "Layer" "0-视口")<br />   (vlax-put-property obj_mv "Color" acYellow)<br />   (vlax-put-property obj_mv "ViewportOn" acTrue)<br />   (vlax-put-property obj_mv "TwistAngle" (* -1 ang))<br />   (vlax-put-property obj_mv "GridOn" acFalse)<br />   ; ActivePViewport示例中有以下说明<br />   ;' 在将图纸空间 Viewport 设为活动前，mspace 属性必须为 True<br />   ;  ThisDrawing.mspace = True<br />   ;  ThisDrawing.ActivePViewport = newPViewport<br />   (vlax-put-property adoc_l "ActiveSpace" acPaperspace)<br />   (vlax-invoke-method (vlax-get-property acad_l "Application") "ZoomExtents")<br />   (vlax-put-property adoc_l "MSpace" acTrue)<br />   (vlax-put-property adoc_l "ActivePViewport" obj_mv)<br />   ;(vlax-put-property adoc_l "ActivePViewport" obj_mv)<br />   (vlax-invoke-method (vlax-get-property acad_l "Application") "ZoomCenter" (vlax-3D-point vpt) 1.0)<br />   (vlax-put-property adoc_l "MSpace" acFalse)<br />   (vlax-put-property obj_mv "CustomScale" (/ 1.0 blx))<br />   ;(vlax-invoke-method (vlax-get-property acad_l "Application") "ZoomPrevious")<br /> <br /> )

e2002

找时间我们聊聊这个问题吧

masterlong

论坛里参照、视口相关的程序
还是太少了
一直想把自己的一些程序放上来
等有空时整理整理

masterlong

计算拉伸后视口对应的模型中心点
这个不难
问题是怎么修改
vla貌似没有方法
entmod对视口图元好像也无效

masterlong

我好像走入误区了？
进入到视口内部
直接vla-ZoomCenter
就不知道速度方面怎么样
等会测试下

叮咚

masterlong 发表于 2021-4-12 14:53
我好像走入误区了？
进入到视口内部
直接vla-ZoomCenter

对啊，我发你的代码中，就是这样啊

masterlong

初步测试
感觉进入视口zoom中心点的做法
比直接视口拉伸要慢好多
差不多1：2的关系

command方式
copy以前先冻结全部图层
拉伸全部完成以后再恢复图层
时间上又能省一半

当然耗时这个不好说
这和模型图元数量
布局视口数量以及切分数量等等
都有很大的关系