LEGEND creation of both block and linetypes From viewport in layout

[smitaranjan]

LEGEND.LSP

Hi anyone can modify the code so it can create legends for both and linetypes with their layer name in description. It's a lee mac's program which creating legend in model space. If by touching the viewport it can make legend at layout whatever showing in the viewport it will be a great help.

[Steven P]

So in his LISP I bet there is an 'ssget' line to select the objects, keeping with Lee Mac look at his ssget reference (http://lee-mac.com/ssget.html) and there is an option in there to change that to 'window' selection... all we need to do is work out the window

 

This LISP will draw the viewport area in modelspace - if that can be adjusted to give the coordinates and not draw anything then job done

 

https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/outline-projection-all-viewports-to-model/td-p/3254748

 

or 

 

https://jtbworld.com/autocad-vp-outline-lsp

 

 

Do you reckon you can work it out from there?

Edited June 2, 2023 by Steven P

[smitaranjan]

5 hours ago, Steven P said:

So in his LISP I bet there is an 'ssget' line to select the objects, keeping with Lee Mac look at his ssget reference (http://lee-mac.com/ssget.html) and there is an option in there to change that to 'window' selection... all we need to do is work out the window

 

This LISP will draw the viewport area in modelspace - if that can be adjusted to give the coordinates and not draw anything then job done

 

https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/outline-projection-all-viewports-to-model/td-p/3254748

 

or 

 

https://jtbworld.com/autocad-vp-outline-lsp

 

 

Do you reckon you can work it out from there?

No may be...how these will help? they have to create extra viewport in layout for legend. Also legend.lsp only make legend for linetype that it makes line continuous and it does not include blocks in legend..I want it to create like this.

[Steven P]

But with the new viewport rectangle will let you use ssget to select the objects, and I am sure there are some changes that can be made in the layers LISP to get say blocks and so on

[Steven P]

Something like this, command is trythis, no nice stuff added like errors, undo, or clear instructions...

 

In a paperspace, select a viewport - this will then use the coordinates of that view and pass it to Lee Macs Layers LISP to select the entities as this LISP does (your link above, also included below with a couple of changes).

 

I did what I suggested above, the VPO lisp taking out the draw rectangle part (commented out below) and returning the list of coordinates to my TryThis LISP. Then passed this LISP to layers LISP. VPO LISP didn't return the coordinates exactly as I wanted to some fixing there

 

Have a look and see what else you want, however it is now the weekend so might have to look at this on Monday

 

 

 

 

;;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/outline-projection-all-viewports-to-model/td-p/3254748
;;MODIFIED - SEE Commented out and added portions

(defun c:VPO (/ _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))) ; end defun

  (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)))
  ) ; end defun

  (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")
;;                          ) ; end list
;;                          lst
;;                  ) ; end append
;;        ) ; end entmake
(princ lst) ;; ADDED
      ) ; end if
    ) ; end if
  )
lst ; return coordinates ADDED
)

;; 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)
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;Lee Mac
;;MODIFIED - SEE Commented out and added portions
(defun C:LEGEND ( sscoords / *error* acdoc acobj an co e hs ht i la lst lt p p1 p2 p3 space ss st ro dr)
  (vl-load-com)
  (setq acObj (vlax-get-acad-object)
        acDoc (vla-get-activedocument acObj)
        space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
  )
  (vla-startundomark acDoc)
  
  ;;;;;; Error function ;;;;;;;;;
  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*"))
      (princ (strcat "\nError: " msg))
      )
    (if (and a (not (vlax-erased-p a))) (vla-delete a))
    (vla-endundomark acDoc)
    (princ)
    )
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq st (entget (tblobjname "style" (getvar 'textstyle)) '("AcadAnnotative"))
        an (member '(1070 . 1) (cdr (member '(1070 . 1) (cadr (assoc -3 st)))))
        hs (cdr (assoc 40 st))
        ro (angle '(0 0 0) (trans (getvar "UCSXDIR") 0 (trans '(0 0 1) 1 0 T)))
        dr (trans '(0 0 1) 1 0 T)
        )
  (if
    an
    (setq ht (/ (if (> hs 0) hs 3.0) (cond ((getvar 'cannoscalevalue)) (1.0))))
    (setq ht (* (if (> hs 0) hs 3.0) (getvar 'ltscale)))
    )
  (if
;;    (setq ss (ssget))
(setq ss (ssget "_WP" sscoords ) ) ;;ADDED

    (progn
      (repeat (setq i (sslength ss))
        (setq
          e  (entget (ssname ss (setq i (1- i))))
          la (cdr (assoc 8  e))
          lt (cdr (assoc 6  e))
          co (cdr (assoc 62 e))
        )
        (if
          (not (member (list la lt co) lst))
          (setq lst (cons (list la lt co) lst))
        )
      )
      (setq lst (vl-sort lst '(lambda (a b) (< (car a) (car b)))))
      (if
        (setq p (getpoint "\nSpecify insert point: "))
        (foreach x lst
          (setq p1 (trans p 1 0)
                p2 (trans (polar p 0.0 (* 10 ht)) 1 0)
                p3 (trans (polar p 0.0 (* 11 ht)) 1 0)
                )
          (entmake
            (list
              '(0 . "LINE")
              (cons 8 (car x))
              (cons 10 p1)
              (cons 11 p2)
              (cons 6  (cond ((cadr  x)) ("ByLayer")))
              (cons 62 (cond ((caddr x)) (256)))
              )
            )
          (vla-put-textalignmentpoint
            (vlax-ename->vla-object
              (entmakex
                (list
                  '(0 . "TEXT")
                  (cons 8 (car x))
                  (cons 6 (cond ((cadr x)) ("ByLayer")))
                  (cons 62 (cond ((caddr x)) (256)))
                  '(100 . "AcDbText")
                  (list 10 0 0 0)
                  (cons 40 ht)
                  (cons 1 (car x))
                  (cons 50 ro)
                  (cons 7 (getvar 'textstyle))
                  (cons 72 0)
                  (list 10 0 0 0)
                  (cons 210 dr)
                  (cons 73 2)
                )
              )
            )
            (vlax-3d-point p3)
          )
          (setq p (polar p (/ pi -2.0) (* 2 ht)))
          )
        )
      )
    )
  (*error* nil)
  (princ)
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(defun c:trythis ( / VPOcoords sscoords )
  (setq VPOcoords (c:vpo)) ;;coords are (10 x y z). Just want x y
;;fix coords
  (setq sscoords (list))
  (foreach n VPOCoords
    (setq sscoords (append sscoords (list (list (nth 1 n) (nth 2 n)) ) ))
  )

  (if (= (getvar 'cvport) 1)
    (command "model")
    ()
  ) ; switch to model space
  (C:LEGEND sscoords)

)

 

 

 

 

 

Google... Brilliant

Edited June 2, 2023 by Steven P

[BIGAL]

I can see problems with a make legend not in the sense of get linetypes and blocks but rather in the descriptions, if you look closely.

Some of the descriptions are 3 lines long. So they would need to be excluded and say added manually, else you need a look up for them and get the details. 

 

So make all linetypes then make Blocks, the SRS linetypes need to be added last. Move the pothole and Bore pit up. Simplest way is to have the Buried fibre and Interduct as external blocks and Insert.

 

Need a real dwg to do real testing. 

 

Steven P pretty sure this returns the 4 corners of a viewport in mspace will try to have a look at Lee's code. Note Twistangle for rotated viewports. Used for grids in layouts.

 

(command "._PSPACE")
(setq sss (ssget "_+.:E:S" (list (cons 0 "Viewport"))))
(setq cspace (cdr (assoc 69 (entget (ssname sss 0)))))

(setq obj (vlax-ename->vla-object (ssname sss 0)))

(if (= (vla-get-objectname obj)  "AcDbViewport")
(progn

(setq  cen (vlax-get obj  'Center ))
(setq ht (vlax-get obj 'Height))
(setq wid  (vlax-get obj 'Width))
(if (> ht wid)
(setq dist (* 0.8 ht))
(setq dist (* 0.8 wid))
)
(setq sc (vlax-get obj 'customscale ))
(setq ang (vlax-get obj 'TwistAngle))
(setq xmin  (- (car cen)(/ wid 2.0)))
(setq xmax  (+ (car cen)(/ wid 2.0)))
(setq ymin  (- (cadr cen)(/ ht 2.0)))
(setq ymax  (+ (cadr cen)(/ ht 2.0)))
(command "zoom" "c" cen 2000)
(command "Mspace")
(setvar 'cvport cspace)
(command "UCS" "w")

 

Edited June 3, 2023 by BIGAL

[Steven P]

I'll check that but that is better code - far shorter than the one I found out

[BIGAL]

Steven if have any problems let me know. 

Edited June 3, 2023 by BIGAL

[Steven P]

Thanks BigAL, I tried that code, gives me the coordinates of the actual viewport? Wanted to coordinates of the area it shows but it did give me some thoughts about angles and so on. Still busy here but something to think about.

 

i think for this one my next step is what the OP needs to show in the legend - it is showing the details from lines and their layers just now

[BIGAL]

I will look into the original code more thought it was correct use trans to convert the corners to world. 

 

Read my comments about some of the legends being inserted.

[smitaranjan]

On 6/2/2023 at 10:32 PM, Steven P said:

Something like this, command is trythis, no nice stuff added like errors, undo, or clear instructions...

 

In a paperspace, select a viewport - this will then use the coordinates of that view and pass it to Lee Macs Layers LISP to select the entities as this LISP does (your link above, also included below with a couple of changes).

 

I did what I suggested above, the VPO lisp taking out the draw rectangle part (commented out below) and returning the list of coordinates to my TryThis LISP. Then passed this LISP to layers LISP. VPO LISP didn't return the coordinates exactly as I wanted to some fixing there

 

Have a look and see what else you want, however it is now the weekend so might have to look at this on Monday

 

 

 

 

;;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/outline-projection-all-viewports-to-model/td-p/3254748
;;MODIFIED - SEE Commented out and added portions

(defun c:VPO (/ _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))) ; end defun

  (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)))
  ) ; end defun

  (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")
;;                          ) ; end list
;;                          lst
;;                  ) ; end append
;;        ) ; end entmake
(princ lst) ;; ADDED
      ) ; end if
    ) ; end if
  )
lst ; return coordinates ADDED
)

;; 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)
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;Lee Mac
;;MODIFIED - SEE Commented out and added portions
(defun C:LEGEND ( sscoords / *error* acdoc acobj an co e hs ht i la lst lt p p1 p2 p3 space ss st ro dr)
  (vl-load-com)
  (setq acObj (vlax-get-acad-object)
        acDoc (vla-get-activedocument acObj)
        space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
  )
  (vla-startundomark acDoc)
  
  ;;;;;; Error function ;;;;;;;;;
  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*"))
      (princ (strcat "\nError: " msg))
      )
    (if (and a (not (vlax-erased-p a))) (vla-delete a))
    (vla-endundomark acDoc)
    (princ)
    )
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq st (entget (tblobjname "style" (getvar 'textstyle)) '("AcadAnnotative"))
        an (member '(1070 . 1) (cdr (member '(1070 . 1) (cadr (assoc -3 st)))))
        hs (cdr (assoc 40 st))
        ro (angle '(0 0 0) (trans (getvar "UCSXDIR") 0 (trans '(0 0 1) 1 0 T)))
        dr (trans '(0 0 1) 1 0 T)
        )
  (if
    an
    (setq ht (/ (if (> hs 0) hs 3.0) (cond ((getvar 'cannoscalevalue)) (1.0))))
    (setq ht (* (if (> hs 0) hs 3.0) (getvar 'ltscale)))
    )
  (if
;;    (setq ss (ssget))
(setq ss (ssget "_WP" sscoords ) ) ;;ADDED

    (progn
      (repeat (setq i (sslength ss))
        (setq
          e  (entget (ssname ss (setq i (1- i))))
          la (cdr (assoc 8  e))
          lt (cdr (assoc 6  e))
          co (cdr (assoc 62 e))
        )
        (if
          (not (member (list la lt co) lst))
          (setq lst (cons (list la lt co) lst))
        )
      )
      (setq lst (vl-sort lst '(lambda (a b) (< (car a) (car b)))))
      (if
        (setq p (getpoint "\nSpecify insert point: "))
        (foreach x lst
          (setq p1 (trans p 1 0)
                p2 (trans (polar p 0.0 (* 10 ht)) 1 0)
                p3 (trans (polar p 0.0 (* 11 ht)) 1 0)
                )
          (entmake
            (list
              '(0 . "LINE")
              (cons 8 (car x))
              (cons 10 p1)
              (cons 11 p2)
              (cons 6  (cond ((cadr  x)) ("ByLayer")))
              (cons 62 (cond ((caddr x)) (256)))
              )
            )
          (vla-put-textalignmentpoint
            (vlax-ename->vla-object
              (entmakex
                (list
                  '(0 . "TEXT")
                  (cons 8 (car x))
                  (cons 6 (cond ((cadr x)) ("ByLayer")))
                  (cons 62 (cond ((caddr x)) (256)))
                  '(100 . "AcDbText")
                  (list 10 0 0 0)
                  (cons 40 ht)
                  (cons 1 (car x))
                  (cons 50 ro)
                  (cons 7 (getvar 'textstyle))
                  (cons 72 0)
                  (list 10 0 0 0)
                  (cons 210 dr)
                  (cons 73 2)
                )
              )
            )
            (vlax-3d-point p3)
          )
          (setq p (polar p (/ pi -2.0) (* 2 ht)))
          )
        )
      )
    )
  (*error* nil)
  (princ)
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(defun c:trythis ( / VPOcoords sscoords )
  (setq VPOcoords (c:vpo)) ;;coords are (10 x y z). Just want x y
;;fix coords
  (setq sscoords (list))
  (foreach n VPOCoords
    (setq sscoords (append sscoords (list (list (nth 1 n) (nth 2 n)) ) ))
  )

  (if (= (getvar 'cvport) 1)
    (command "model")
    ()
  ) ; switch to model space
  (C:LEGEND sscoords)

)

 

 

 

 

 

Google... Brilliant

Tried, its not giving block and linetype also not visible, and its asking insert point at model space instead of layout. I am attaching a dwg file you can try TEST-01.dwg

[Steven P]

That is OK, just checking we are going in the right direction for you. Does it select the view port area OK as you want? A question from what BigAl said earlier, are any of your viewports rotated or are they all aligned to model space?

 

For the blocks, are you just wanting a list of all the blocks and then the block name:

 

For example:

 

[block lines]       Block Name

 

Should be easy to add, all drawn in black (or whatever layer 0 is set to)

 

Linetype? Not sure what you want for here

 

 

get the legend details as you want and the insertion point is easy.

 

 

 

 

perhaps while I think about this you could find out the ssget code to select just blocks - will help me in the blocks part of the legend

 

(Note to others... this is a good learning point for the OP to start making up their own LISPS......)

 

 

[smitaranjan]

59 minutes ago, Steven P said:

That is OK, just checking we are going in the right direction for you. Does it select the view port area OK as you want? A question from what BigAl said earlier, are any of your viewports rotated or are they all aligned to model space?

 

For the blocks, are you just wanting a list of all the blocks and then the block name:

 

For example:

 

[block lines]       Block Name

 

Should be easy to add, all drawn in black (or whatever layer 0 is set to)

 

Linetype? Not sure what you want for here

 

 

get the legend details as you want and the insertion point is easy.

 

 

 

 

perhaps while I think about this you could find out the ssget code to select just blocks - will help me in the blocks part of the legend

 

(Note to others... this is a good learning point for the OP to start making up their own LISPS......)

 

 

yes...its selecting the viewport and which is exactly I want... then its asking to insert point in model space. I have attached dwg, in layout legend is created by me manually, that's the result I want from lisp, if possible.

[smitaranjan]

5 minutes ago, smitaranjan said:

yes...its selecting the viewport and which is exactly I want... then its asking to insert point in model space. I have attached dwg, in layout legend is created by me manually, that's the result I want from lisp, if possible.

TEST-01.pdfYOU can see the pdf file example and can try the code in dwg file to check.

[Steven P]

Yup, working this out as and when I get a moment, lots of parts and not finished.

 

This is the basics of adding the blocks to the legend

 

For inserting the legend in paper space, you could look at the code below and perhaps using an internet search work out where to put the switch back to paper space - saves me a task and I've decided that is something you can add and learn a little too.

 

This replaces 'c:legend' in the code above

 

(defun C:LEGEND ( sscoords / *error* acdoc acobj an co e hs ht i la lst bnlst lt p p1 p2 p3 space ss st ro dr)
  (defun emakeline ( x p1 / )
    (entmake
      (list
        '(0 . "LINE")
        (cons 8 (car x))
        (cons 10 p1)
        (cons 11 p2)
        (cons 6  (cond ((cadr  x)) ("ByLayer")))
        (cons 62 (cond ((caddr x)) (256)))
      ) ; end list
    ) ; end entmake
  ) ; end defun

  (defun emaketxt ( x Txt dr p3 ro / )
    (vla-put-textalignmentpoint
      (vlax-ename->vla-object
        (entmakex
          (list
            '(0 . "TEXT")
            (cons 8 (car x))
            (cons 6 (cond ((cadr x)) ("ByLayer")))
            (cons 62 (cond ((caddr x)) (256)))
            '(100 . "AcDbText")
            (list 10 0 0 0)
            (cons 40 ht)
            (cons 1 Txt)
            (cons 50 ro)
            (cons 7 (getvar 'textstyle))
            (cons 72 0)
            (list 10 0 0 0)
            (cons 210 dr)
            (cons 73 2)
          ) ; end list
        ) ; end entmakex
      ) ; end vlax-ename....
      (vlax-3d-point p3)
    ) ; end vla-put-text...
  ) ; end defun



  (vl-load-com)
  (setq acObj (vlax-get-acad-object)
        acDoc (vla-get-activedocument acObj)
        space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
  )
  (vla-startundomark acDoc)
  
  ;;;;;; Error function ;;;;;;;;;
  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*"))
      (princ (strcat "\nError: " msg))
      )
    (if (and a (not (vlax-erased-p a))) (vla-delete a))
    (vla-endundomark acDoc)
    (princ)
    )
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq st (entget (tblobjname "style" (getvar 'textstyle)) '("AcadAnnotative"))
        an (member '(1070 . 1) (cdr (member '(1070 . 1) (cadr (assoc -3 st)))))
        hs (cdr (assoc 40 st))
        ro (angle '(0 0 0) (trans (getvar "UCSXDIR") 0 (trans '(0 0 1) 1 0 T)))
        dr (trans '(0 0 1) 1 0 T)
        )
  (if
    an
    (setq ht (/ (if (> hs 0) hs 3.0) (cond ((getvar 'cannoscalevalue)) (1.0))))
    (setq ht (* (if (> hs 0) hs 3.0) (getvar 'ltscale)))
    )
  (if
;;    (setq ss (ssget))
(setq ss (ssget "_WP" sscoords ) ) ;;ADDED
    (progn
      (repeat (setq i (sslength ss))
        (setq
          e  (entget (ssname ss (setq i (1- i))))
bn (cdr (assoc 2  e)) ;;ADDED ;;block name
          la (cdr (assoc 8  e))
          lt (cdr (assoc 6  e))
          co (cdr (assoc 62 e))
        )
        (if
          (not (member (list la lt co) lst))
          (setq lst (cons (list la lt co) lst))
        )
(if ;; get unique block names ;; ADDED
  (and
    (not (member (list bn) bnlst)) ;;ADDED
    (not (= bn nil)) ;;ADDED
  )
  (setq bnlst (cons (list bn) bnlst)) ;;ADDED
) ; end if ;; ADDED
      )
      (setq lst (vl-sort lst '(lambda (a b) (< (car a) (car b)))))
(setq bnlst (vl-sort bnlst '(lambda (a b) (< (car a) (car b))))) ;; ADDED, Sort block list
        
;;SORT OF A <MASSIVE HINT HERE - SWITCH TO MODEL SPACE HERE
        
        
      (if
        (setq p (getpoint "\nSpecify insert point: "))
(progn
        (foreach x lst
          (setq p1 (trans p 1 0)
                p2 (trans (polar p 0.0 (* 10 ht)) 1 0)
                p3 (trans (polar p 0.0 (* 11 ht)) 1 0)
          ) ; end setq
;          (entmake
;            (list
;              '(0 . "LINE")
;              (cons 8 (car x))
;              (cons 10 p1)
;              (cons 11 p2)
;              (cons 6  (cond ((cadr  x)) ("ByLayer")))
;              (cons 62 (cond ((caddr x)) (256)))
;              )
;            )
;          (vla-put-textalignmentpoint
;            (vlax-ename->vla-object
;              (entmakex
;                (list
;                  '(0 . "TEXT")
;                  (cons 8 (car x))
;                  (cons 6 (cond ((cadr x)) ("ByLayer")))
;                  (cons 62 (cond ((caddr x)) (256)))
;                  '(100 . "AcDbText")
;                  (list 10 0 0 0)
;                  (cons 40 ht)
;                  (cons 1 (car x))
;                  (cons 50 ro)
;                  (cons 7 (getvar 'textstyle))
;                  (cons 72 0)
;                  (list 10 0 0 0)
;                  (cons 210 dr)
;                  (cons 73 2)
;                ) ; end list
;              ) ; end entmakex
;            ) ; end vlax-ename....
;            (vlax-3d-point p3)
;          ) ; end vla-put-text...

(emakeline x p1) ;; ADDED
(emaketxt x (car x) dr p3 ro) ;; ADDED

          (setq p (polar p (/ pi -2.0) (* 2 ht)))
          ) ; end foreach x


(foreach y bnlst ;;ADDED
  (setq p1 (trans p 1 0) ;;ADDED
        p2 (trans (polar p 0.0 (* 10 ht)) 1 0) ;;ADDED 
        p3 (trans (polar p 0.0 (* 11 ht)) 1 0) ;;ADDED
  ) ; end setq ;;ADDED

;;Get Bounding Box of Block, and work out X / Y coordinates for text
  (command "-insert" (car y) p1 1 1 0) ;; ADDED
  (emaketxt (list "0" nil 256 ) (car y) dr p3 ro) ;; ADDED ;; text layer 0, bylayer coplour & linetype
  (setq p (polar p (/ pi -2.0) (* 2 ht))) ;;ADDED
) ; end foreach y ;;ADDED


) ; end progn ;;ADDED
        ) ; end if
      ) ; end progm
    ) ; end if
  (*error* nil)
  (princ)
  )

 

 

This works just needs some nice stuff added like lining up the blocks and texts. All based on Lee Macs original code, 'Added' added where I added lines

Edited June 6, 2023 by Steven P

[Tharwat]

@smitaranjan I have sent you a private message regarding the program.

[Tharwat]

Here is my version but its not a freeware. 

 

[Steven P]

Slight update to mine above just part way to lining the blocks and text up nicer - let us know though if Tharwats solution works for you

[smitaranjan]

40 minutes ago, Steven P said:

Slight update to mine above just part way to lining the blocks and text up nicer - let us know though if Tharwats solution works for you

the price seems a bit high...so no deal. Not good for me

Edited June 8, 2023 by smitaranjan

[Steven P]

Unfortunately, that's the way things are - a dedicated and speedy response or take things slower and get something that might not be exactly what you want. In defence of paying for a LISP, most bosses are reluctant unless you can demonstrate that the cost will give a decent time saving - which is all I want, a few LISPs that gives me 10 minutes extra in the day to make a nice cup of tea,