Viewport na modelu


Recommended Posts

Cześć,

Przesiadłem się ostatnio na GstarCAD'a a jak wiadomo przy takowej zmianie lubią wysypać się różne krzaczki, oto i jeden:

Posiadam lisp do pokazywania linii viewportów z layoutów na modelu (możliwość zaznaczenia kilku viewportów/każdy layout posiada inne kolory). W autocadzie działał bez zarzutów, natomiast w gstarcad'zie  mogę zaznaczyć viewporty, tworzy odpowiednią warstwę, ale niczego nie pokazuje na modelu. Czy istnieje jakaś możliwość, abym uruchomił to pod Gstarem?

Spoiler

(defun c:bvp (/ *error* ss p1 p2 id ent vpID clay)
  (defun *error* (errmsg)
    (while (> (getvar "CMDACTIVE") 0) (princ "\n***") (command))
    (setvar "EXPERT" 0)
    (setvar "CECOLOR" "BYLAYER")
    (if clay (setvar "CLAYER" clay))
    (princ "\n** ERROR **\n")
    (princ errmsg)(terpri)
    (command "_.undo" "_end")
    (princ)
  )
  (setvar "CMDECHO" 0)
  (setvar "EXPERT" 1)
  (if (= (getvar "TILEMODE") 0)
    (progn
      (if (/= (getvar "CVPORT") 1)
        (progn
          (command "._pspace")
          (princ "Switching to Paper space.")
        )
      )
      (if (or (setq ss (ssget "_I" '((0 . "VIEWPORT")))) (setq ss (ssget '((0 . "VIEWPORT")))))
        (progn
          (setq id -1)
          (command "_.undo" "_begin")
          (setq clay (getvar "CLAYER"))
          (makelay "vp-outline" 5 "Continuous")
          (command "._-layer" "_Plot" "_No" "vp-outline" "_Set" "vp-outline" "")
          (command "._vplayer" "_Vpvisdflt" "vp-outline" "_Frozen" "")
          (command "._vplayer" "_Freeze" "vp-outline" "_All" "")
          (repeat (sslength ss)
            (setq ent (ssname ss (setq id (1+ id))))
            (setq vpID (dxf 69 (entget ent)))
            (if (> vpID 1)
              (progn
                (setvar "CECOLOR" (rtos (dxf (dxf 410 (entget ent)) (layoutorderlist)) 2 0))
                (vpo ent)
                (if (not (tblsearch "APPID" "VPO"))
                  (regapp "VPO")
                )
                (entmod (append (entget (entlast)) (list (list -3 (list "VPO" (cons 1000 (dxf 410 (entget ent))))))))
              )
            )
          )
          (setvar "CECOLOR" "BYLAYER")
          (setvar "CLAYER" clay)
          (command "_.undo" "_end")
        )
        (command "_.graphscr")
      )
    )
    (progn
      (princ "\n** Command not allowed in Model Tab **")
      (command "_.graphscr")
    )
  )
  (setvar "EXPERT" 0)
  (princ)
)
 

 

Link to comment
Share on other sites

Załączam całość

 

Spoiler

(defun dictobjname (ename symbol) (cdr (assoc -1 (dictsearch ename symbol))))

(defun dxf (dxf ename) (cdr (assoc dxf ename)))

(defun layoutorderlist (/ tblrewind dictename ent layoutname layoutorder layoutorderlist)
  (setq tblrewind 1)
  (setq dictename (dictobjname (namedobjdict) "ACAD_LAYOUT"))
  (while (setq ent (member '(100 . "AcDbLayout") (dictnext dictename tblrewind)))
    (setq tblrewind nil)
    (setq layoutname (dxf 1 ent)) ;Layout name
    (setq layoutorder (dxf 71 ent)) ;Tab order
    (setq layoutorderlist (append layoutorderlist (list (cons layoutname layoutorder))))
  )
  (setq layoutorderlist (vl-sort layoutorderlist '(lambda (x y) (< (cdr x) (cdr y)))))
)

(defun c:mvp (/ *error* ss p1 p2 id ent vpID vpStatus vpLock vpOn vpNotActive vpCB)
  (defun *error* (errmsg)
    (while (> (getvar "CMDACTIVE") 0) (princ "\n***") (command))
    (setvar "EXPERT" 0)
    (princ "\n** ERROR **\n")
    (princ errmsg)(terpri)
    (command "_.undo" "_end")
    (princ)
  )
  (setvar "CMDECHO" 0)
  (setvar "EXPERT" 1)
  (if (= (getvar "TILEMODE") 0)
    (progn
      (if (/= (getvar "CVPORT") 1)
        (progn
          (command "._pspace")
          (princ "Switching to Paper space.")
        )
      )
      (if (or (setq ss (ssget "_I" '((0 . "VIEWPORT")))) (setq ss (ssget '((0 . "VIEWPORT")))))
        (progn
          (setq p1 (getpoint "\nSpecify base point:"))
          (setq p2 (getpoint p1 "\nSpecify second point:"))
          (setq id -1)
          (command "_.undo" "_begin")
          (command "._mspace")
          (repeat (sslength ss)
            (setq ent (ssname ss (setq id (1+ id))))
            (setq vpID (dxf 69 (entget ent)))
            (setq vpStatus (dxf 90 (entget ent)))
            (setq vpLock (= (logand vpStatus 16384) 16384))
            (setq vpOn (dxf 68 (entget ent)))
            (if (eq vpOn -1)
              (command "_.mview" "_ON" ent "") ;Viewport was not active!
            )
            (if (eq vpOn 0)
              (progn
                ;(princ "\nViewport was off!")
                (command "_.mview" "_ON" ent "")
              )
            )
            (if vpLock
              (progn
                ;(princ "\nViewport was locked!")
                (command "_.mview" "_l" "_off" ent "")
              )
            )
            (if (setq vpNotActive (eq (dxf 68 (entget ent)) -1)) ;Viewport is still not active!
              (progn
                ;(princ "\nViewport was still not active, so was zoomed to it!")
                (command "_.pspace")
                (if (setq vpCB (dxf 340 (entget ent)))
                  (command "_.zoom" "_O" vpCB "")
                  (command "_.zoom" "_O" ent "")
                )
                (command "_.mview" "_ON" ent "")
                (command "._mspace")
              )
            )
            (setvar "CVPORT" vpID)
            (command "_.-pan" (trans p1 2 0) (trans p2 2 0))
            (if vpLock
              (command "_.mview" "_l" "_on" ent "")
            )
            (if vpNotActive
              (progn
                (command "_.pspace")
                (command "_.zoom" "_P")
                (command "._mspace")
              )
            )
          )
          (command "_.pspace")
          (command "_.undo" "_end")
        )
        (command "_.graphscr")
      )
    )
    (progn
      (princ "\n** Command not allowed in Model Tab **")
      (command "_.graphscr")
    )
  )
  (setvar "EXPERT" 0)
  (princ)
)

(defun makelay (LName LColor LType)
  (if (not(tblsearch "LAYER" LName))
    (entmake (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               (cons 2  LName) ;layer name
               (cons 6  (if (and LType (tblobjname "ltype" LType)) LType  "Continuous")) ;linetype
               (cons 62  LColor) ;layer color
               '(70 . 0) ; on, unlocked, thawed
               '(290 . 1) ;plotting flag
               '(370 . -3) ;lineweight
             )
    )
  )
)

(defun c:bvp (/ *error* ss p1 p2 id ent vpID clay)
  (defun *error* (errmsg)
    (while (> (getvar "CMDACTIVE") 0) (princ "\n***") (command))
    (setvar "EXPERT" 0)
    (setvar "CECOLOR" "BYLAYER")
    (if clay (setvar "CLAYER" clay))
    (princ "\n** ERROR **\n")
    (princ errmsg)(terpri)
    (command "_.undo" "_end")
    (princ)
  )
  (setvar "CMDECHO" 0)
  (setvar "EXPERT" 1)
  (if (= (getvar "TILEMODE") 0)
    (progn
      (if (/= (getvar "CVPORT") 1)
        (progn
          (command "._pspace")
          (princ "Switching to Paper space.")
        )
      )
      (if (or (setq ss (ssget "_I" '((0 . "VIEWPORT")))) (setq ss (ssget '((0 . "VIEWPORT")))))
        (progn
          (setq id -1)
          (command "_.undo" "_begin")
          (setq clay (getvar "CLAYER"))
          (makelay "vp-outline" 5 "Continuous")
          (command "._-layer" "_Plot" "_No" "vp-outline" "_Set" "vp-outline" "")
          (command "._vplayer" "_Vpvisdflt" "vp-outline" "_Frozen" "")
          (command "._vplayer" "_Freeze" "vp-outline" "_All" "")
          (repeat (sslength ss)
            (setq ent (ssname ss (setq id (1+ id))))
            (setq vpID (dxf 69 (entget ent)))
            (if (> vpID 1)
              (progn
                (setvar "CECOLOR" (rtos (dxf (dxf 410 (entget ent)) (layoutorderlist)) 2 0))
                (vpo ent)
                (if (not (tblsearch "APPID" "VPO"))
                  (regapp "VPO")
                )
                (entmod (append (entget (entlast)) (list (list -3 (list "VPO" (cons 1000 (dxf 410 (entget ent))))))))
              )
            )
          )
          (setvar "CECOLOR" "BYLAYER")
          (setvar "CLAYER" clay)
          (command "_.undo" "_end")
        )
        (command "_.graphscr")
      )
    )
    (progn
      (princ "\n** Command not allowed in Model Tab **")
      (command "_.graphscr")
    )
  )
  (setvar "EXPERT" 0)
  (princ)
)

(defun c:sbvp ( / )
  (sssetfirst nil (ssget "_X" '((0 . "LWPOLYLINE") (-3 ("VPO")))))
  (princ)
)

(defun c:gotovp ( / ss ent lay)
  (sssetfirst nil nil)
  (if (setq ss (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-3 ("VPO")))))
    (progn
      (setq ent (ssname ss 0))
      (setq lay (cdr (car (cdr (assoc "VPO" (cdr (assoc -3 (entget ent '("*")))))))))
      (if (member lay (layoutlist))
        (setvar "CTAB" lay)
        (princ (strcat "\n** Error: Layout " lay " don't exist **"))
      )
    )
  )
  (princ)
)

;; Viewport Outline  -  Lee Mac
;; Generates an LWPolyline in Modelspace representing the outline of
;; a selected Paperspace Viewport. Compatible with all Rectangular
;; and Polygonal Viewports (including those with Arc segments), and
;; with all views & construction planes.

(defun vpo ( vpt / cen ent lst ocs vpe )

    (setq vpt (entget vpt))
    (if (setq ent (cdr (assoc 340 vpt)))
        (setq lst (LM:polyvertices ent))
        (setq cen (mapcar 'list (cdr (assoc 10 vpt))
                      (list
                          (/ (cdr (assoc 40 vpt)) 2.0)
                          (/ (cdr (assoc 41 vpt)) 2.0)
                      )
                  )
              lst (mapcar
                     '(lambda ( a ) (cons (mapcar 'apply a cen) '(42 . 0.0)))
                     '((- -) (+ -) (+ +) (- +))
                  )
        )
    )
    (setq vpe (cdr (assoc -1 vpt))
          ocs (cdr (assoc 16 vpt))
    )
    (entmake
        (append
            (list
               '(000 . "LWPOLYLINE")
               '(100 . "AcDbEntity")
               '(100 . "AcDbPolyline")
                (cons 90 (length lst))
               '(070 . 1)
               '(410 . "Model")
            )
            (apply 'append (mapcar '(lambda ( x ) (list (cons 10 (trans (pcs2wcs (car x) vpe) 0 ocs)) (cdr x))) lst))
            (list (cons 210 ocs))
        )
    )
    (princ)
)

;; Polyline Vertices  -  Lee Mac
;; Returns a list of vertices for a POLYLINE or LWPOLYLINE entity

(defun LM:polyvertices ( ent )
    (apply '(lambda ( foo bar ) (foo bar))
        (if (= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
            (list
                (lambda ( enx )
                    (if (setq enx (member (assoc 10 enx) enx))
                        (cons (cons  (cdr (assoc 10 enx)) (assoc 42 enx)) (foo (cdr enx)))
                    )
                )
                (entget ent)
            )
            (list
                (lambda ( ent / enx )
                    (if (= "VERTEX" (cdr (assoc 0 (setq enx (entget ent)))))
                        (cons (cons (cdr (assoc 10 enx)) (assoc 42 enx)) (foo (entnext ent)))
                    )
                )
                (entnext ent)
            )
        )
    )
)

;; PCS2WCS (gile)
;; Translates a PCS point to WCS based on the supplied Viewport
;; (PCS2WCS pt vp) is the same as (trans (trans pt 3 2) 2 0) when vp is active
;; pnt : PCS point
;; ent : Viewport ename

(defun PCS2WCS ( pnt ent / ang enx mat nor scl )
    (setq pnt (trans pnt 0 0)
          enx (entget ent)
          ang (- (cdr (assoc 51 enx)))
          nor (cdr (assoc 16 enx))
          scl (/ (cdr (assoc 45 enx)) (cdr (assoc 41 enx)))
          mat (mxm
                  (mapcar (function (lambda ( v ) (trans v 0 nor t)))
                     '(   (1.0 0.0 0.0)
                          (0.0 1.0 0.0)
                          (0.0 0.0 1.0)
                      )
                  )
                  (list
                      (list (cos ang) (- (sin ang)) 0.0)
                      (list (sin ang)    (cos ang)  0.0)
                     '(0.0 0.0 1.0)
                  )
              )
    )
    (mapcar '+
        (mxv mat
            (mapcar '+
                (vxs pnt scl)
                (vxs (cdr (assoc 10 enx)) (- scl))
                (cdr (assoc 12 enx))
            )
        )
        (cdr (assoc 17 enx))
    )
)

;; Matrix Transpose  -  Doug Wilson
;; Args: m - nxn matrix

(defun trp ( m )
    (apply 'mapcar (cons 'list m))
)

;; Matrix x Matrix  -  Vladimir Nesterovsky
;; Args: m,n - nxn matrices

(defun mxm ( m n )
    ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)

;; Matrix x Vector  -  Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n

(defun mxv ( m v )
    (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

;; Vector x Scalar  -  Lee Mac
;; Args: v - vector in R^n, s - real scalar

(defun vxs ( v s )
    (mapcar '(lambda ( n ) (* n s)) v)
)

(princ)

 

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...
 Share