HELP: LISP to create multiple & resized viewport base on an existing viewport

[vernonlee]

I've made this one, using a different approach

(vl-load-com)

(defun C:CPVP (/ *error* acObj acDoc vp enti p1 p2 enti cen sc newcen dims)
 (setq acObj (vlax-get-acad-object)
       acdoc (vla-get-activedocument acObj)
       )
 
 (vla-startundomark acDoc)
 
 (defun *error* (msg)
   (and
     msg
     (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*"))
     (princ (strcat "\nError: " msg))
   )
   (if
     (= 8 (logand (getvar 'undoctl) )
     (vla-endundomark acDoc)
   )
   (princ)
 )

 (if
   (and
     (setq vp (ssget ":E:S:L" '((0 . "VIEWPORT"))))
     (setq p1 (getpoint "\nFirst corner: "))
     (setq p2 (getcorner p1 "\nSecond corner: "))
   )
    (progn
      (setq p1     (trans p1 1 0)
            p2     (trans p2 1 0)
            enti   (vla-copy (vlax-ename->vla-object (ssname vp 0)))
            sc     (vla-get-CustomScale enti)
            newcen (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2)
            dims   (mapcar '- p2 p1)
      )
      (if (= (vla-get-clipped enti) :vlax-true)
        (command "_clip" (vlax-vla-object->ename enti) "_d")
      )
      (vla-update enti)
      (setq cen (vlax-get enti 'center))
      (vla-put-mspace acdoc :vlax-true)
      (vla-put-activepviewport acdoc enti)
      (vla-zoomCenter acObj (vlax-3d-point (trans (trans newcen 3 2) 2 0)) 1)
      (vla-put-mspace acdoc :vlax-false)
      (vla-put-width  enti (abs (car  dims)))
      (vla-put-height enti (abs (cadr dims)))
      (vla-put-center enti (vlax-3d-point newcen))
      (vla-put-CustomScale enti sc)
      (command "_move" (vlax-vla-object->ename enti) "" "_non" p1)
      (while (> (getvar 'cmdactive) 0)
        (command "\\")
        )
    )
 )
 (*error* nil)
 (princ)
)

 

OMG it worked

 

Thanks to Stefan you have no idea how much time & effort you have saved me:celebrate:

 

Thanks David also for continuously helping me out

[vernonlee]

I've made this one, using a different approach

 

Hi Stefan,

 

If you could, perhaps you can remove the displacement option if possible.

 

I would not need that as it will always (without fail) be in the same location. It would speed up the process as well. .

 

Thanks

[Stefan BMR]

vernonlee said:

OMG it worked

 

Thanks to Stefan you have no idea how much time & effort you have saved me:celebrate:

 

Thanks David also for continuously helping me out

You're welcome vernonlee. I'm glad it helps you.

I always wanted to write a function like this for my own use... I guess I'm to lazy...

vernonlee said:

Hi Stefan,

 

If you could, perhaps you can remove the displacement option if possible.

 

I would not need that as it will always (without fail) be in the same location. It would speed up the process as well. .

 

Thanks

 

Sure, try this one. It is slightly modified. Now you can continuously create new viewports.

(defun C:CPVP (/ *error* get_viewport acObj acDoc vp new_vp p1 p2 new_vp sc new_cen dims vp_border) (vl-load-com)
 
 (defun get_viewport (e)
   (cond
     ((not e) nil)
     ((eq (cdr (assoc 0 (entget e))) "VIEWPORT") e)
     ((vl-some
        '(lambda (x)
           (if
             (eq (cdr (assoc 0 (entget (cdr x)))) "VIEWPORT")
             (cdr x)
           )
         )
         (reverse
           (cdr (member '(102 . "}")
             (reverse
               (cdr (member '(102 . "{ACAD_REACTORS") (entget e)))
             )
           )
         )
       )
     )
   ))
 )
 
 (setq acObj (vlax-get-acad-object)
       acDoc (vla-get-activedocument acObj)
 )

 (vla-startundomark acDoc)

 (defun *error* (msg)
   (and
     msg
     (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*"))
     (princ (strcat "\nError: " msg))
   )
   (if
     (= 8 (logand (getvar 'undoctl) 8))
      (vla-endundomark acDoc)
   )
   (princ)
 )
 
 (if
   (and
     (cond
       ((= (getvar 'cvport) 1))
       ((= (getvar 'tilemode) 0) (vla-put-mspace acdoc :vlax-false) T)
       ((not (princ "\nNot allowed in ModelSpace")))
       )
     (progn
       (while
         (progn
           (setvar 'errno 0)
           (setq vp (car (entsel "\nSelect viewport: ")))
           (if
             (= (getvar 'errno) 7)
             (progn (princ "\nMissed. Try again") (setvar 'errno 0))
             (if
               (not (setq vp (get_viewport vp)))
               (princ "\nNot a viewport. Try again")
             )
           )
         )
       )
       vp
     )
   )
   (while
     (setq p1 (getpoint "\nFirst corner: "))
       (if
         (and
           (setq p2 (getcorner p1 "\nSecond corner: "))
           (not (equal
                  (rem
                    (angle
                      (setq p1 (trans p1 1 0))
                      (setq p2 (trans p2 1 0))
                      )
                  (/ pi 2.0)) 0.0 1e-8)
                )
          )
          (progn
            (if
              (setq vp_border (cdr (assoc 340 (entget vp))))
              (command "_copy" vp vp_border "" '(0 0 0) '(0 0 0)
                       "_clip" (setq new_vp (get_viewport (entlast))) "_d")
              (progn
                (command "_copy" vp "" '(0 0 0) '(0 0 0))
                (setq new_vp (entlast))
                )
              )
            (setq new_vp  (vlax-ename->vla-object new_vp)
                  sc      (vla-get-CustomScale new_vp)
                  new_cen (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2)
                  dims    (mapcar '- p2 p1)
            )
            (vla-put-mspace acdoc :vlax-true)
            (vla-put-activepviewport acdoc new_vp)
            (vla-zoomCenter acObj (vlax-3d-point (trans (trans new_cen 3 2) 2 0)) 1)
            (vla-put-mspace acdoc :vlax-false)
            (vla-put-width  new_vp (abs (car  dims)))
            (vla-put-height new_vp (abs (cadr dims)))
            (vla-put-center new_vp (vlax-3d-point new_cen))
            (vla-put-CustomScale new_vp sc)
;;;             (command "_move" (vlax-vla-object->ename new_vp) "" "_non" (trans p1 0 1))
;;;             (while (> (getvar 'cmdactive) 0)
;;;               (command "\\")
;;;             )             
          )
       )
    )
 )
 (*error* nil)
 (princ)
)

 

Edited July 28, 2022 by Stefan BMR
Fixed for clipped viewports

[vernonlee]

You're welcome vernonlee. I'm glad it helps you.

I always wanted to write a function like this for my own use... I guess I'm to lazy...

 

 

Sure, try this one. It is slightly modified. Now you can continuously create new viewports.

 

 

AWESOME!!!!!!!!!!!!

 

 

 

 

 

 

Thanks Stefan. you are a life saver.

 

Good thing you had the same idea as well.

 

Kudos to you as well David as it would not have started without you

Edited October 23, 2014 by vernonlee

[Stefan BMR]

Post 23 updated. Now it works properly on clipped viewports.

[vernonlee]

Post 23 updated. Now it works properly on clipped viewports.

 

 

Wow. Thanks for the updates. I did encounter some before. Amazing. The previous also works on locked view ports which is excellent.

 

Am now on holiday .

 

Will test it when I am back home.

 

Cheers bro.

 

P/s

 

I forgot to test it, but I hope it follows the original viewport layering settings (example the new viewport can follow the original viewport setting whereby certain layer is off or frozen within the viewport )

 

Thanks

[vernonlee]

Post 23 updated. Now it works properly on clipped viewports.

 

Back in the office.

 

The new viewports created using the lisp, will follow the VP states. Except for transparency. But no biggie

 

Regarding the clipped viewports, i realized i do not know that function.

[Stefan BMR]

Back in the office.

 

The new viewports created using the lisp, will follow the VP states. Except for transparency. But no biggie

 

Regarding the clipped viewports, i realized i do not know that function.

 

Layer's override transparency is an XRECORD attached to the layer object, like any other override properties.

I must admit, I didn't check my lisp for any of this override properties, I thought that COPY command will take care of this. It does, for color, linetype and lineweight, but not for transparency, despite the fact that all are managed in the same way by autocad. It might be a bug in autocad.

Use matchprop command to solve this situation...

 

About clipped viewports. Mview command has "Object" option. If you create a viewport using this option and you pick a closed shape (polyline, circle, ellipse, region or spline), the result is a clipped viewport. Also, you can use CLIP command to clip an existing viewport.

[vernonlee]

Layer's override transparency is an XRECORD attached to the layer object, like any other override properties.

I must admit, I didn't check my lisp for any of this override properties, I thought that COPY command will take care of this. It does, for color, linetype and lineweight, but not for transparency, despite the fact that all are managed in the same way by autocad. It might be a bug in autocad.

Use matchprop command to solve this situation...

 

About clipped viewports. Mview command has "Object" option. If you create a viewport using this option and you pick a closed shape (polyline, circle, ellipse, region or spline), the result is a clipped viewport. Also, you can use CLIP command to clip an existing viewport.

 

Hi Stefan. Like i said no big issue. Honestly what you had written is God sent for me already. Really

 

Thanks for the heads-up on the clip viewport. I also did look it up on my own & realised I mistaken it for something else.

 

Thanks again Stefan. Your contribution will help me immensely.

 

Cheer man

[vernonlee]

Hi Stefan

 

I have encountered some of the existing drawings that i worked on frequently have errors when running the LISP.

 

Would you know what is wrong?

 

Thanks

 

 

VIEWPORT NOT ABLE TO CREATE IN THIS DRAWING.dwg

[Stefan BMR]

Hi vernonlee

 

Try with REGENAUTO set to ON.

[vernonlee]

Hi vernonlee

 

Try with REGENAUTO set to ON.

 

wow bro. it worked.

 

Not sure why some of the existing drawings I open is Off & some is ON.

 

Any setting I can adjust so that every drawing i open, the REGENAUTO will be set to ON? Is it drawing or my autocad system related?

 

Thanks.