Visual LISP, AutoLISP and General Customization

[#1]

Hello everybody,

I have been using one routine very successfully to create a pline in modelspace that has the outline of the chosen viewports in the drawing. This one works great.
Now I am trying add other routines that I've done to better fit my needs. If I use each routine individually at the command line they work, but when I use all in a single command I got the following errors:

The routine SetColor - does not change color to Bylayer
The routine RectWidth - ; error: bad SSGET list

Why?

See the attached file for more details and be free to improve whatever you want in my routines because they are very basic.

And, if I am not asking to much, is that possible to not be prompt to select objects? I mean, the routine could automatically select all viewports in the drawing...

Thanks for helping.

[#2]

Msargui,

Add this line after (c:MakeViewportOutline) and before your (c:RectWidth)

(setvar 'ctab "Model")

by the way prefixing the function name with 'C:' declars it as a new autocad command

(that can be call from the command line).

if you do not intend to call these functions individually? you can remove the 'C:'  prefix, (c:vpo) is sufficient.

(c:MakeLayer)
(cetColor)
(c:MakeViewportOutline)
(c:RectWidth)

Cheers,

Moshe

[#3]

I didn't troubleshoot your code but found one here: http://www.jtbworld.com/lisp/vp-outline.htm  by Jimmy Bergmark and modified it to be on your layer and with your command "VPO". It appears to work well.

[#4 · Accepted solution]

---

msarqui wrote:

Hello everybody,

Why?

Thanks for helping.

---

(defun c:VPO ()
  	(setvar 'pickfirst 1)
  	(c:MakeLayer)
        (c:SetColor)
  	(sssetfirst nil (ssget "_x" '((0 . "VIEWPORT"))))
        (c:MakeViewportOutline)
        (c:RectWidth)
)

(defun c:Rectwidth (/ wd ltscl)
  	(if (setq pl (ssget "_X" '((0 . "LWPOLYLINE")(8 . "Tx-Viewport")(410 . "Model"))))
          	(progn
                    (command "._pedit" "_m" pl "" "w" "200" "")
                    (command "._chprop" pl "" "ltscale" "1000" "")
                  )
          )
  )

HTH

[#5]

Hello guys,

Moshe-A : Thanks for the tip. I did not know I could write the commands without the "c" prefix.

bcinnv : I was intrigued when you said you didn't troubleshoot my code so I spent the weekend testing all possibilities and could not solve. Today when I went to work, I tested the routine in the office and it worked without problems. I think I inadvertently changed a system variable and now the routine does not work on my home computer. What I need do is to figure out which variable I changed.

pbejse : Perfect solution for not having to select objects, it works nice.

I made a cosmetic change in your Rectwidth suggestion and it works very well.

(defun c:Rectwidth (/ pl)

                (if (setq pl (ssget "_X" '((0 . "LWPOLYLINE")(8 . "Tx-Viewport")(410 . "Model"))))

                (progn

                    (command "._pedit" "_m" pl "" "w" "200" "")

                    (command "._chprop" pl "" "ltscale" "1000" "")

                 )

         )

(princ)

)

 Thanks for all the replies.

[#6]

---

msarqui wrote:

pbejse : Perfect solution for not having to select objects, it works nice.

---

Glad I could help

Kudos to alanjt_ & gile. 

[#7]

Nice codes from Alan, Gile, pbjese, you and I couldn't resist to add something mine...

Hope this is what you're looking for...

M.R.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;               Load all Linetypes from acadiso.lin file               ;;
;;                         from: ribarm                                 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:Loadltypes ( / fn f rl ltname ltypes )
  (setq fn (open (setq f (findfile "acadiso.lin")) "r"))
  (while (setq rl (read-line fn))
    (if (eq "*" (substr rl 1 1)) (setq ltname (substr rl 1 (vl-string-position (ascii ",") rl))))
    (if ltname
      (progn
        (setq ltname (vl-string-left-trim "*" ltname))
        (setq ltypes (cons ltname ltypes))
      )
    )
  )
  (foreach ln ltypes
    (command "_.linetype" "l" f "" "s" ln "")
  )
  (command "_.linetype" "s" "ByLayer" "")
  (princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                    Make a layer Tx-Viewport                          ;;
;;                         from: msarqui                                ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun C:Makelayer ()
  (if (not (tblsearch "LAYER" "Tx-Viewport"))
    (command "-layer" "m" "Tx-Viewport" "lt" "hidden" "" "c" "191" "" "")
  )
(princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                   Set th current color Bylayer                       ;;
;;                         from: msarqui                                ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;if the color of the current layer in the Color Control of the Properties Toolbar;
;is set to another color then Bylayer, the new layer Tx-Viewport will assume the ;
;color 191 but will not show it. So I forced the system variable "cecolor" to 256;

(defun c:SetColor ()
  (setvar "cecolor" "BYLAYER")
(princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;http://forums.autodesk.com/t5/Visual-LISP-AutoLISP-and-General/Outline-projection-all-viewports-to-m...
;;                                              Make a viewport outline                                                       ;;
;;                                               from : alanjt_ & gile                                                        ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:MakeViewportOutline (/ _trans _cornersFromBBox ss i ent data ent2 lst)
  ;; Viewport Outline
  ;; Require subroutine: PCS2WCS (and all subs it requires)
  ;; PCS2WCS by gile (http://www.theswamp.org/index.php?topic=29231.msg347755#msg347755)
  ;; Alan J. Thompson, 12.08.11

  (vl-load-com)

  (defun _trans (p) (cons 10 (PCS2WCS p ent)))

  (defun _cornersFromBBox (o / a b)
    (vla-getboundingbox o 'a 'b)
    (setq a (_trans (vlax-safearray->list a))
          b (_trans (vlax-safearray->list b))
    )
    (list a (list (car a) (cadr a) (caddr b)) b (list (car b) (cadr b) (caddr a)))
  )

  (if (setq ss (ssget '((0 . "VIEWPORT"))))
    (repeat (setq i (sslength ss))
      (setq ent  (ssname ss (setq i (1- i)))
            data (entget ent)
      )

      (if (if (setq ent2 (cdr (assoc 340 data)))
            (setq lst (apply 'append
                             (mapcar '(lambda (x)
                                        (if (eq (car x) 10)
                                          (list (_trans (cdr x)))
                                        )
                                      )
                                     (entget ent2)
                             )
                      )
            )
            (setq lst (_cornersFromBBox (vlax-ename->vla-object ent)))
          )
        (entmakex (append (list '(0 . "LWPOLYLINE")
                                '(100 . "AcDbEntity")
                                '(100 . "AcDbPolyline")
                                (cons 90 (length lst))
                                '(70 . 1)
                                '(410 . "Model")
                          )
                          lst
                  )
        )
      )
    )
  )
  (princ)
)

;; WCS2PCS (gile)
;; Translates a point WCS coordinates to the PaperSpace CS according to
;; the specified Viewport
;; 
;; (WCS2PCS pt vp) is the same as (trans (trans pt 0 2) 2 3) when vp is active
;;
;; Arguments
;; pt : a point
;; vp : the viewport (ename or vla-object)

(defun WCS2PCS (pt vp / elst ang nor scl mat)
  (vl-load-com)
  (and (= (type vp) 'VLA-OBJECT)
       (setq vp (vlax-vla-object->ename vp))
  )
  (setq pt   (trans pt 0 0)
        elst (entget vp)
        ang  (cdr (assoc 51 elst))
        nor  (cdr (assoc 16 elst))
        scl  (/ (cdr (assoc 41 elst)) (cdr (assoc 45 elst)))
        mat  (mxm
               (list (list (cos ang) (- (sin ang)) 0.0)
                     (list (sin ang) (cos ang) 0.0)
                     '(0.0 0.0 1.0)
               )
               (mapcar (function (lambda (v) (trans v nor 0 T)))
                       '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
               )
             )
  )
  (mapcar '+
          (vxs (mxv mat (mapcar '- pt (cdr (assoc 17 elst)))) scl)
          (vxs (cdr (assoc 12 elst)) (- scl))
          (cdr (assoc 10 elst))
  )
)

;; PCS2WCS (gile)
;; Translates a point PaperSpace coordinates to WCS coordinates
;; according to the specified viewport
;;
;; (PCS2WCS pt vp) is the same as (trans (trans pt 3 2) 2 0) when vp is active
;;
;; Arguments
;; pt : a point
;; vp : the viewport (ename or vla-object)

(defun PCS2WCS (pt vp / ang nor scl mat)
  (vl-load-com)
  (and (= (type vp) 'VLA-OBJECT)
       (setq vp (vlax-vla-object->ename vp))
  )
  (setq pt   (trans pt 0 0)
        elst (entget vp)
        ang  (- (cdr (assoc 51 elst)))
        nor  (cdr (assoc 16 elst))
        scl  (/ (cdr (assoc 45 elst)) (cdr (assoc 41 elst)))
        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 pt scl)
                       (vxs (cdr (assoc 10 elst)) (- scl))
                       (cdr (assoc 12 elst))
               )
          )
          (cdr (assoc 17 elst))
  )
)

;; VXS Multiply a vector by a scalar
;;
;; Arguments : a vector and a real

(defun vxs (v s) (mapcar (function (lambda (x) (* x s))) v))

;; VXV (gile)
;; Returns the dot product of two vectors (real)
;;
;; Arguments : two vectors
;; return : a real number

(defun vxv (v1 v2) (apply '+ (mapcar '* v1 v2)))

;; TRP
;; transposes a matrix -Doug Wilson-
;;
;; Argument : a matrix
;; return : a matrix

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

;; MXV
;; Applies a transformation matrix to a vector  -Vladimir Nesterovsky-
;;
;; Arguments : une matrice et un vecteur
;; return : a vector

(defun mxv (m v)
  (mapcar '(lambda (r) (vxv r v)) m)
)

;; MXM
;; Multiplies (combinates) two matrices -Vladimir Nesterovsky-
;;
;; Arguments : deux matrices
;; return : a matrix

(defun mxm (m q)
  (mapcar '(lambda (r) (mxv (trp q) r)) m)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Change the width and the ltscale of the projected viewport outlines  ;;
;;                     to make them more visible                        ;;
;;              from: msarqui & a little help from pbejse               ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:Rectwidth ( / pl r )
  (if (setq pl (ssget "_X" '((0 . "LWPOLYLINE")(8 . "Tx-Viewport")(410 . "Model"))))
    (progn
      (command "._pedit" "_m" pl "" "w" (if (eq (setq r (fix (/ (getvar 'viewsize) 200.0))) 0) 0.1 r) "")
      (command "._chprop" pl "" "ltscale" (if (eq r 0) 1.0 r) "")
    )
  )
  (princ)
)
;------------------------------------
;shortcut
(defun c:VPO ( / pck ss )
    (setq pck (getvar 'pickfirst))
    (setvar 'pickfirst 1)
    (c:Loadltypes)
    (c:MakeLayer)
    (c:SetColor)
    (foreach lay (layoutlist)
      (setvar 'ctab lay)
      (sssetfirst nil (ssdel (ssname (setq ss (ssget "_X" (list '(0 . "VIEWPORT") (cons 410 (getvar 'ctab))))) (- (sslength ss) 1)) ss))
      (c:MakeViewportOutline)
    )
    (setvar 'tilemode 1)
    (command "_.zoom" "e")
    (c:RectWidth)
    (command "_.zoom" "e")
    (setvar 'pickfirst pck)
)
;------------------------------------