Create new layer LISP

October 20, 2018

Is it possible to insert "specify lineweight" in this code after choosing color? Tnx

(defun c:nl ( / *error* check_name acdoc ss fname op_file dcl name r i la col)
  (if (setq ss (ssget "_I")) (setq ss (ssget ":L")))

  (setq acDoc (vla-get-activedocument (vlax-get-acad-object)))

  (if (= 8 (logand (getvar 'undoctl) 8)) (vla-endundomark acDoc))
  (vla-startundomark acDoc)

  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*EXIT*,*QUIT*,*BREAK*"))
      (princ (strcat "\nError: " msg))
      )
    (if fname (vl-catch-all-apply 'vl-file-delete (list fname)))
    (vla-endundomark acDoc)
    (princ)
  )

  (setq
    fname (vl-filename-mktemp "newlayer" (getvar 'dwgprefix) ".dcl")
    op_file (open fname "w")
  )

  (foreach x
    '("newlayer : dialog {"
      ": spacer { height = 1;}"
      ": text { alignment = left; label = \"Enter Layer Name\";}"
      ": edit_box {alignment = left; key = \"name\"; edit_width = 40;}"
      ": spacer { height = 1;}"
      "ok_cancel;"
      "errtile;}"
     )
    (write-line x op_file)
  )
  (close op_file)
  
  (defun check_name (str)
    (if
      (wcmatch str "*<*,*>*,*/*,*\\*,*:*,*;*,*`?*,*`**,*|*,*`,*,*=*,*``*")
      (progn
        (set_tile "error" "Invalid character. Do not use <>/\\\":;?*|,=`")
        (mode_tile "name" 2)
        )
      (set_tile "error" "")
      )
    )

  (if
    (and
      (> (setq dcl (load_dialog fname)) 0)
      (new_dialog "newlayer" dcl)
      )
    (progn
      (set_tile "name" (setq name (cond (ss (cdr (assoc 8 (entget (ssname ss 0))))) ("New Layer"))))
      (action_tile "name" "(setq name $value) (check_name name)")
      (setq r (start_dialog))
      (unload_dialog dcl)
      )
    )
  (if
    (and
      (= r 1)
      (/= name "")
      )
    (progn
      (if
        (not (tblsearch "layer" name))
        (progn
          (setq la (vla-add (vla-get-layers acdoc) name))
          (if
            (setq col (acad_colordlg 7))
            (vla-put-color la col)
            )
          T
          )
        (setq la (vla-item (vla-get-layers acdoc) name))
        )
      (if
        (/= name (getvar 'clayer))
        (progn
          (vla-put-freeze la :vlax-false)
          (setvar 'clayer name)
          )
        )
      (if ss
        (repeat (setq i (sslength ss))
          (vla-put-layer (vlax-ename->vla-object (ssname ss (setq i (1- i)))) name)
          )
        )     
      )
    )
  (*error* nil)
  (princ)
  )

October 20, 2018

I found a solution.

(command "_.-Layer""lw" pause "" "")

NL.lsp

October 21, 2018

FWIW

(wcmatch str "*<*,*>*,*/*,*\\*,*:*,*;*,*`?*,*`**,*|*,*`,*,*=*,*``*")

can be

(not (snvalid str ) )

October 21, 2018

Please post the source, where you got this code from.

October 22, 2018

On 10/21/2018 at 12:23 PM, Grrr said:

Please post the source, where you got this code from.

Hi Grrr

It's my code, but no header in the original lisp file... My mistake.

Edit: Actually, the original lisp HAS a header. I don't know why the web version doesn't have one...

The original file is on a commercial site, so I cannot post a link, sorry

On 10/21/2018 at 11:44 AM, hanhphuc said:
FWIW
(wcmatch str "*<*,*>*,*/*,*\\*,*:*,*;*,*`?*,*`**,*|*,*`,*,*=*,*``*")
can be
(not (snvalid str ) )

You are right, already changed some time ago

On 10/20/2018 at 4:21 PM, drdownload18 said:

Is it possible to insert "specify lineweight" in this code after choosing color? Tnx

Try the attached lisp.

NewLayer v1.02.lsp

Edited October 22, 2018 by Stefan BMR

October 23, 2018

On 10/22/2018 at 3:33 PM, Stefan BMR said:

Hi Grrr

It's my code, but no header in the original lisp file... My mistake.

Edit: Actually, the original lisp HAS a header. I don't know why the web version doesn't have one...

The original file is on a commercial site, so I cannot post a link, sorry

Hi Stefan,

I pointed that out, because the coding is good but I couldn't recognise who's style it was.

For a long time (few years) a "quick layer" routine was on my todolist, but finally got the skills to write one myself (per mine requirements).

And finally managed to utilise my ImageButtonColorPrompt subfoo, as it got rusty in my archive. ( @rlx might like it, since I took the idea from one of his DCL routines )

; QuickLayer - Grrr
; Credits to Lee Mac
(defun C:test ( / layers tmpL *error* dcl des dch dcf lnm col rtn )
  
  (setq layers ((lambda ( / d L ) (while (setq d (tblnext "LAYER" (not d))) (setq L (cons (cdr (assoc 2 d)) L))) L)))
  
  (setq tmpL
    '( (87 114 105 116 116 101 110 32 98 121 32 71 114 114 114)
      (_Transparency ( k def / i L )
        (repeat (setq i 91) (setq L (cons (itoa (setq i (1- i))) L)))
        (start_list k) (mapcar 'add_list L) (end_list)
        (set_tile k (itoa (vl-position def L)))
        L
      )
      (_Plottable ( k def / L ) (start_list k) (mapcar 'add_list (setq L '("Yes" "No"))) (end_list) L )
      (_Lineweight ( k def / r )
        (start_list k)
        (mapcar 'add_list
          (mapcar 
            '(lambda (x)
              (
                (lambda (xx / tmp) 
                  (cond 
                    ( (= 3 (length (setq tmp (vl-string->list xx))))
                      (apply '(lambda (a b c) (vl-list->string (list a 46 b c))) tmp)
                    )
                    ( (= 11 (strlen xx)) (substr xx 5) )
                    ( xx )
                  )
                )
                (substr (vl-prin1-to-string x) 7)
              )
            )
            (setq r
              '( 
                acLnWtByLayer acLnWtByBlock acLnWtByLwDefault 
                acLnWt000  acLnWt005 acLnWt009 acLnWt013 acLnWt015 
                acLnWt018  acLnWt020 acLnWt025 acLnWt030 acLnWt035 acLnWt040 
                acLnWt050  acLnWt053  acLnWt060 acLnWt070 acLnWt080 acLnWt090 
                acLnWt100 acLnWt106 acLnWt120 acLnWt140 acLnWt158 acLnWt200 acLnWt211 
              )
            )
          )
        )
        (end_list)
        (set_tile k (itoa (vl-position def r))) 
        r
      )
      (_Linetype ( k def / d L )
        (while (setq d (tblnext "LTYPE" (not d))) (setq L (cons (cdr (assoc 2 d)) L)))
        (if L 
          (progn
            (setq L (acad_strlsort L))
            (start_list k) (mapcar 'add_list L) (end_list)
            (set_tile k (itoa (vl-position def L))) 
            L
          )
        )
      )
    )
  )
  
  (defun *error* ( msg )
    (and (< 0 dch) (unload_dialog dch))
    (and (eq 'FILE (type des)) (close des))
    (and (eq 'STR (type dcl)) (findfile dcl) (vl-file-delete dcl))
    (and msg (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\nError: " msg)))) (princ)
  )
  
  (cond
    (
      (not
        (and (setq dcl (vl-filename-mktemp nil nil ".dcl")) (setq des (open dcl "w"))
          (mapcar (function (lambda (x) (princ (strcat "\n" x) des))) 
            '("test : dialog "
              "{ label = \"Quick Layer\"; width = 36;  spacer_1;"
              "  : boxed_column"
              "  { label = \"Input Layer Name\"; "
              "    : edit_box { key = \"lnm\"; fixed_width = false; }"
              "    spacer;"
              "  }"
              "  spacer_1;"
              "  : boxed_column"
              "  { alignment = centered; label = \"Layer Properties\"; children_fixed_width = false;"
              "    spacer;"
              "    : row"
              "    {  "
              "      : text { label = \"Color\"; alignment = left; }"
              "      : spacer { width = 2.0; }"
              "      : image_button { key = \"col\"; width = 2.4; aspect_ratio = 1.8; color = graphics_background; fixed_width = false; } "
              "    }"
              "    : popup_list { label = \"Transparency\";  key = \"trn\"; edit_width = 6; }"
              "    : popup_list { label = \"Plottable?\";    key = \"plt\"; edit_width = 6; }"
              "    : popup_list { label = \"Lineweight\";    key = \"lw\"; edit_width = 16; }"
              "    : popup_list { label = \"Linetype\";      key = \"lt\"; edit_width = 16; }"
              "    spacer_1;"
              "    : row { alignment = centered; spacer; : toggle { label = \"Current?\"; key = \"cur\"; alignment = centered; value = 1; } } "
              "    spacer_1; " 
              "  }"
              "  spacer_1; ok_cancel; errtile;"
              "}"
              
            )
          )
          (not (setq des (close des))) (< 0 (setq dch (load_dialog dcl))) 
        )
      )
      (prompt "\nUnable to write or load the DCL file.")
    )
    ( (not (new_dialog "test" dch)) (prompt "\nUnable to display the dialog") )
    (
      (progn 
        (mode_tile "lnm" 2)
        (ImageButtonColorPrompt "col" 20 'col)
        (setq tmpL (apply 'mapcar (cons  ''(( x k d ) ((cdr x) k d)) (cons (cdr tmpL) '(("trn" "plt" "lw" "lt") ("0" "Yes" acLnWtByLayer "Continuous"))))))
        (foreach x '(lnm accept)
          (action_tile (strcase (vl-prin1-to-string x) t) 
            (vl-prin1-to-string
              '(
                (lambda ( lnm / tmp )
                  (setq tmp (strcase lnm))
                  (cond 
                    ( (not (snvalid lnm)) (set_tile "error" (strcat "Invalid layer name: " lnm)) (if (= $key "lnm") (set_tile $key $data) (mode_tile "lnm" 2)) )
                    ( (setq tmp (vl-some '(lambda (x) (if (= tmp (strcase x)) x)) layers)) (set_tile "error" (strcat "Layer \"" tmp "\" exists!")) (if (= $key "lnm") (set_tile $key $data) (mode_tile "lnm" 2)) )
                    (t (if (= $key "lnm") (client_data_tile $key lnm))
                      (set_tile "error" (strcat "Layername \"" lnm "\" is fine"))
                      (if
                        (or
                          (/= $key "lnm")
                          (and (= $key "lnm") (= 1 $reason))
                        )
                        (progn
                          (setq rtn
                            (append (list (cons 'col col)) 
                              (mapcar ''((x) (cons x (get_tile (strcase (vl-prin1-to-string x) t)))) '(lnm cur))
                              (mapcar ''((k a) (cons (read k) (nth (atoi (get_tile k)) a))) '("trn" "plt" "lw" "lt") tmpL)
                            )
                          )
                          (done_dialog 1)
                        )
                      )
                    )
                  )
                )
                (get_tile "lnm")
              )
            )
          )
        )
        (/= 1 (setq dcf (start_dialog)))
      )
      (prompt "\nUser cancelled or terminated the dialog.")
    )
    (
      (
        '(( / f L )
          (setq f '((k L)(cdr (assoc k L))))
          (setq L (list (f 'lnm rtn) (f 'col rtn) (f 'lt rtn) (eval (f 'lw rtn)) (= "Yes" (f 'plt rtn)) (atoi (f 'trn rtn)) (= "1" (f 'cur rtn))))
          (apply 'CreateLayer L) 
        )
      )
    )
  )
  (*error* nil) (princ) 
)








; This one is assembled by Grrr...

; key - [STR] key of an image_button
; def - [INT] ACI value for the very first default color prompt
; sym - [SYM] symbol name to bound the value
; the return value is stored in the specified symbol
; Note1: the specified ACI color is stored in the tile's $data (so it would be default for further inputs)
; Note2: for true colors its recomended (LM:True->ACI) function
; Usage example: (ImageButtonColorPrompt "img1" 20 'col)

'(87 114 105 116 116 101 110 32 98 121 32 71 114 114 114)
(defun ImageButtonColorPrompt ( key def sym )
  (action_tile key
    (strcat 
      "(setq " (vl-prin1-to-string sym) " "
      "  ("
      "    (lambda ( def )"
      (vl-prin1-to-string
        (quote
          (
            (lambda ( / tmp val )
              (if
                (setq tmp 
                  (acad_truecolordlg 
                    (cond 
                      ( (and $data (/= $data "") (setq tmp (read $data)))
                        (cond 
                          ( (assoc 430 tmp) )
                          ( (assoc 420 tmp) )
                          ( (assoc 62 tmp) )
                        )
                      )
                      (def) (1)
                    )
                    t
                  )
                )
                (
                  (lambda ( k col / w h )
                    (setq w (1- (dimx_tile k))) (setq h (1- (dimy_tile k)))
                    (start_image k) (fill_image 0 0 w h col) (end_image) 
                    (client_data_tile $key (vl-prin1-to-string tmp))
                    
                    tmp
                  )
                  $key
                  (cond 
                    ( (and LM:True->ACI (setq val (cdr (assoc 420 tmp)))) (LM:True->ACI val) )
                    ( (cdr (assoc 62 tmp)) )
                  )
                )
              )
            )
          )
        )
      )
      "    )"
      (cond (def (vl-prin1-to-string def)) ("nil"))
      "  )"
      ")"
    )
  )
)



; This one is assembled by Grrr from Lee Mac's subfunctions here and there...
'(67 114 101 100 105 116 115 32 116 111 32 76 101 101 32 77 97 99)
(defun CreateLayer ( name colour linetype lineweight plot transparency makecurrent / rtn )
  (regapp "accmtransparency")
  (if (not (tblobjname "LAYER" name))
    (setq rtn
      (entmake 
        (append
          '((0 . "LAYER")(100 . "AcDbSymbolTableRecord")(100 . "AcDbLayerTableRecord")(70 . 0))
          (list (cons 2 name) (cons 6 (if (tblsearch "LTYPE" linetype) linetype "Continuous")) )
          colour
          (list (cons 290 (if plot 1 0)) (cons 370 lineweight) )
          (if transparency
            (list (list -3 (list "accmtransparency" (cons 1071 ( (lambda ( x ) (logior (fix (* 2.55 (- 100 x))) 33554432)) transparency ))))) 
          )
        )
      ) 
    )
  )
  (if makecurrent (setvar 'clayer name)) rtn
)



;; True -> ACI  -  Lee Mac
;; Args: c - [int] True Colour

(defun LM:True->ACI ( c / o r )
  (apply 'LM:RGB->ACI (LM:True->RGB c))
)



;; RGB -> ACI  -  Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values

(defun LM:RGB->ACI ( r g b / c o )
  (if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
    (progn
      (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
      (vlax-release-object o)
      (if (vl-catch-all-error-p c)
        (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
        c
      )
    )
  )
)


;; True -> RGB  -  Lee Mac
;; Args: c - [int] True Colour

(defun LM:True->RGB ( c )
  (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24))
)


;; Application Object  -  Lee Mac
;; Returns the VLA Application Object

(defun LM:acapp nil
  (eval (list 'defun 'LM:acapp 'nil (vlax-get-acad-object)))
  (LM:acapp)
)

October 23, 2018

2 hours ago, Grrr said:

For a long time (few years) a "quick layer" routine was on my todolist, but finally got the skills to write one myself (per mine requirements).

And finally managed to utilise my ImageButtonColorPrompt subfoo, as it got rusty in my archive. ( @rlx might like it, since I took the idea from one of his DCL routines )

Nice one Grrr. Having all the settings right in front of you and ready to use is definitely faster than Layer Manager, especially when you use a large number of layers.

I've made this lisp for my own use and, because of my working style (same CTB used for a long time based on colors only, no LineWeight, no True Colors), layer name and the color is just fine. Adding more features makes it slow and you can lose almost any advantage over the Layer Manager. Again, my simple lisp was exactly what I needed.
Anyway, the ORIGINAL idea was not the speed! If you test my lisp, when you pre-select some objects then run the lisp, in the end all selected objects will be on the new created layer, and that is how I use it.

October 24, 2018

12 hours ago, Grrr said:

Hi Stefan,

I pointed that out, because the coding is good but I couldn't recognise who's style it was.

For a long time (few years) a "quick layer" routine was on my todolist, but finally got the skills to write one myself (per mine requirements).

And finally managed to utilise my ImageButtonColorPrompt subfoo, as it got rusty in my archive. ( @rlx might like it, since I took the idea from one of his DCL routines )

@Grrr nice

can you replicate this bug? "®ë÷ZàÊ0ìº Ê ý"

1.Input new name,eg: ABC

2.click any popup list

3.edit to 0 (which layer exists)

4.click again any popup list

October 24, 2018

10 hours ago, Stefan BMR said:

Nice one Grrr. Having all the settings right in front of you and ready to use is definitely faster than Layer Manager, especially when you use a large number of layers.

Thanks, few years ago I thought about the advantages and the disadvantages of prompting the user with a dialog to collect inputs.

Resulted with the impression that if the routine prompts the user more than 3 times via getXXX functions it will start to get annoying (esp if there are many optional prompts)

so to use DCL to collect inputs instead.

On the other hand if the routine requires a single entsel or getpoint, and the other settings are optional - then using dialog would be annoying

(imagine MATCHPROPS or LAYMCUR with dialogs - would be so annoying for one that uses them oftenly).

Well good examples can be seen from Lee Mac or Tharwat's routines.. where they still use dialog but its optional to display it to fill in additional settings.

11 hours ago, Stefan BMR said:

Anyway, the ORIGINAL idea was not the speed! If you test my lisp, when you pre-select some objects then run the lisp, in the end all selected objects will be on the new created layer, and that is how I use it.

I saw the concept behind it and I like it, because its short and simple - assigning new layer for the current selection.

BTW if you want it to make a bit faster and more user-friendly, so when the dialog is displayed

the user would be able to instantly to start typing, and when done to just hit the ENTER key (while the focus is still on the edit_box), consider substituting your progn expr with this one -

(progn
  ; (check_name) not required
  (mode_tile "name" 2) ; initially set focus to the edit_box
  ; don't populate anything initially to the edit_box:
  ; (set_tile "name" (setq name (cond (ss (cdr (assoc 8 (entget (ssname ss 0))))) ("New Layer"))))
  (action_tile "name" 
    "(or 
    (and (tblsearch \"LAYER\" $value) (set_tile \"error\" \"This layer exists\"))
    (and (snvalid $value) (setq name $value) (= 1 $reason) (done_dialog 1))
    (set_tile \"error\" \"Invalid layer name\")
    )"
  ); action_tile
  (setq r (start_dialog))
  (unload_dialog dcl)
); progn

1 hour ago, hanhphuc said:

@Grrr nice

can you replicate this bug? "®ë÷ZàÊ0ìº Ê ý"

1.Input new name,eg: ABC

2.click any popup list

3.edit to 0 (which layer exists)

4.click again any popup list

Thanks!

Unfortunately no, if I correctly tried replicate the problem -

However 1 bug exists, because I assigned the same action to the lnm and accept tiles in order to reduce 'duplicate' coding:

1. Fill in correct layer name

2. Do something on the popup_lists (to just change focus)

3. Go back to the edit_box and fill wrong or existing layer name

4. Press OK,

And you'll be prompted that the layername is wrong, but then the routine assigns the previously stored valid value and then exits the dialog and creates the layer.

That problem is easy fixable if two separate actions are used for these tiles.

October 24, 2018

@Grrr , nothing short but impressive! Even though some parts of your code are like digital-SM to me haha. Will have to study it more closely whenever I have more time. Major shutdown on the way at the company I work and at the end of this year the entire engineering department will be outsourced so not sure how my future here (if any) will look like in the months to come. Probably safe until spring / early summer but I'm not sure if I would call it a bad thing if my services would no longer be needed haha. Wouldn't mind a new challenge.

January 11, 2019

On 10/23/2018 at 11:36 PM, Grrr said:

Hi Stefan,

I pointed that out, because the coding is good but I couldn't recognise who's style it was.

For a long time (few years) a "quick layer" routine was on my todolist, but finally got the skills to write one myself (per mine requirements).

And finally managed to utilise my ImageButtonColorPrompt subfoo, as it got rusty in my archive. ( @rlx might like it, since I took the idea from one of his DCL routines )


; QuickLayer - Grrr
; Credits to Lee Mac
(defun C:test ( / layers tmpL *error* dcl des dch dcf lnm col rtn )
  
  (setq layers ((lambda ( / d L ) (while (setq d (tblnext "LAYER" (not d))) (setq L (cons (cdr (assoc 2 d)) L))) L)))
  
  (setq tmpL
    '( (87 114 105 116 116 101 110 32 98 121 32 71 114 114 114)
      (_Transparency ( k def / i L )
        (repeat (setq i 91) (setq L (cons (itoa (setq i (1- i))) L)))
        (start_list k) (mapcar 'add_list L) (end_list)
        (set_tile k (itoa (vl-position def L)))
        L
      )
      (_Plottable ( k def / L ) (start_list k) (mapcar 'add_list (setq L '("Yes" "No"))) (end_list) L )
      (_Lineweight ( k def / r )
        (start_list k)
        (mapcar 'add_list
          (mapcar 
            '(lambda (x)
              (
                (lambda (xx / tmp) 
                  (cond 
                    ( (= 3 (length (setq tmp (vl-string->list xx))))
                      (apply '(lambda (a b c) (vl-list->string (list a 46 b c))) tmp)
                    )
                    ( (= 11 (strlen xx)) (substr xx 5) )
                    ( xx )
                  )
                )
                (substr (vl-prin1-to-string x) 7)
              )
            )
            (setq r
              '( 
                acLnWtByLayer acLnWtByBlock acLnWtByLwDefault 
                acLnWt000  acLnWt005 acLnWt009 acLnWt013 acLnWt015 
                acLnWt018  acLnWt020 acLnWt025 acLnWt030 acLnWt035 acLnWt040 
                acLnWt050  acLnWt053  acLnWt060 acLnWt070 acLnWt080 acLnWt090 
                acLnWt100 acLnWt106 acLnWt120 acLnWt140 acLnWt158 acLnWt200 acLnWt211 
              )
            )
          )
        )
        (end_list)
        (set_tile k (itoa (vl-position def r))) 
        r
      )
      (_Linetype ( k def / d L )
        (while (setq d (tblnext "LTYPE" (not d))) (setq L (cons (cdr (assoc 2 d)) L)))
        (if L 
          (progn
            (setq L (acad_strlsort L))
            (start_list k) (mapcar 'add_list L) (end_list)
            (set_tile k (itoa (vl-position def L))) 
            L
          )
        )
      )
    )
  )
  
  (defun *error* ( msg )
    (and (< 0 dch) (unload_dialog dch))
    (and (eq 'FILE (type des)) (close des))
    (and (eq 'STR (type dcl)) (findfile dcl) (vl-file-delete dcl))
    (and msg (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\nError: " msg)))) (princ)
  )
  
  (cond
    (
      (not
        (and (setq dcl (vl-filename-mktemp nil nil ".dcl")) (setq des (open dcl "w"))
          (mapcar (function (lambda (x) (princ (strcat "\n" x) des))) 
            '("test : dialog "
              "{ label = \"Quick Layer\"; width = 36;  spacer_1;"
              "  : boxed_column"
              "  { label = \"Input Layer Name\"; "
              "    : edit_box { key = \"lnm\"; fixed_width = false; }"
              "    spacer;"
              "  }"
              "  spacer_1;"
              "  : boxed_column"
              "  { alignment = centered; label = \"Layer Properties\"; children_fixed_width = false;"
              "    spacer;"
              "    : row"
              "    {  "
              "      : text { label = \"Color\"; alignment = left; }"
              "      : spacer { width = 2.0; }"
              "      : image_button { key = \"col\"; width = 2.4; aspect_ratio = 1.8; color = graphics_background; fixed_width = false; } "
              "    }"
              "    : popup_list { label = \"Transparency\";  key = \"trn\"; edit_width = 6; }"
              "    : popup_list { label = \"Plottable?\";    key = \"plt\"; edit_width = 6; }"
              "    : popup_list { label = \"Lineweight\";    key = \"lw\"; edit_width = 16; }"
              "    : popup_list { label = \"Linetype\";      key = \"lt\"; edit_width = 16; }"
              "    spacer_1;"
              "    : row { alignment = centered; spacer; : toggle { label = \"Current?\"; key = \"cur\"; alignment = centered; value = 1; } } "
              "    spacer_1; " 
              "  }"
              "  spacer_1; ok_cancel; errtile;"
              "}"
              
            )
          )
          (not (setq des (close des))) (< 0 (setq dch (load_dialog dcl))) 
        )
      )
      (prompt "\nUnable to write or load the DCL file.")
    )
    ( (not (new_dialog "test" dch)) (prompt "\nUnable to display the dialog") )
    (
      (progn 
        (mode_tile "lnm" 2)
        (ImageButtonColorPrompt "col" 20 'col)
        (setq tmpL (apply 'mapcar (cons  ''(( x k d ) ((cdr x) k d)) (cons (cdr tmpL) '(("trn" "plt" "lw" "lt") ("0" "Yes" acLnWtByLayer "Continuous"))))))
        (foreach x '(lnm accept)
          (action_tile (strcase (vl-prin1-to-string x) t) 
            (vl-prin1-to-string
              '(
                (lambda ( lnm / tmp )
                  (setq tmp (strcase lnm))
                  (cond 
                    ( (not (snvalid lnm)) (set_tile "error" (strcat "Invalid layer name: " lnm)) (if (= $key "lnm") (set_tile $key $data) (mode_tile "lnm" 2)) )
                    ( (setq tmp (vl-some '(lambda (x) (if (= tmp (strcase x)) x)) layers)) (set_tile "error" (strcat "Layer \"" tmp "\" exists!")) (if (= $key "lnm") (set_tile $key $data) (mode_tile "lnm" 2)) )
                    (t (if (= $key "lnm") (client_data_tile $key lnm))
                      (set_tile "error" (strcat "Layername \"" lnm "\" is fine"))
                      (if
                        (or
                          (/= $key "lnm")
                          (and (= $key "lnm") (= 1 $reason))
                        )
                        (progn
                          (setq rtn
                            (append (list (cons 'col col)) 
                              (mapcar ''((x) (cons x (get_tile (strcase (vl-prin1-to-string x) t)))) '(lnm cur))
                              (mapcar ''((k a) (cons (read k) (nth (atoi (get_tile k)) a))) '("trn" "plt" "lw" "lt") tmpL)
                            )
                          )
                          (done_dialog 1)
                        )
                      )
                    )
                  )
                )
                (get_tile "lnm")
              )
            )
          )
        )
        (/= 1 (setq dcf (start_dialog)))
      )
      (prompt "\nUser cancelled or terminated the dialog.")
    )
    (
      (
        '(( / f L )
          (setq f '((k L)(cdr (assoc k L))))
          (setq L (list (f 'lnm rtn) (f 'col rtn) (f 'lt rtn) (eval (f 'lw rtn)) (= "Yes" (f 'plt rtn)) (atoi (f 'trn rtn)) (= "1" (f 'cur rtn))))
          (apply 'CreateLayer L) 
        )
      )
    )
  )
  (*error* nil) (princ) 
)








; This one is assembled by Grrr...

; key - [STR] key of an image_button
; def - [INT] ACI value for the very first default color prompt
; sym - [SYM] symbol name to bound the value
; the return value is stored in the specified symbol
; Note1: the specified ACI color is stored in the tile's $data (so it would be default for further inputs)
; Note2: for true colors its recomended (LM:True->ACI) function
; Usage example: (ImageButtonColorPrompt "img1" 20 'col)

'(87 114 105 116 116 101 110 32 98 121 32 71 114 114 114)
(defun ImageButtonColorPrompt ( key def sym )
  (action_tile key
    (strcat 
      "(setq " (vl-prin1-to-string sym) " "
      "  ("
      "    (lambda ( def )"
      (vl-prin1-to-string
        (quote
          (
            (lambda ( / tmp val )
              (if
                (setq tmp 
                  (acad_truecolordlg 
                    (cond 
                      ( (and $data (/= $data "") (setq tmp (read $data)))
                        (cond 
                          ( (assoc 430 tmp) )
                          ( (assoc 420 tmp) )
                          ( (assoc 62 tmp) )
                        )
                      )
                      (def) (1)
                    )
                    t
                  )
                )
                (
                  (lambda ( k col / w h )
                    (setq w (1- (dimx_tile k))) (setq h (1- (dimy_tile k)))
                    (start_image k) (fill_image 0 0 w h col) (end_image) 
                    (client_data_tile $key (vl-prin1-to-string tmp))
                    
                    tmp
                  )
                  $key
                  (cond 
                    ( (and LM:True->ACI (setq val (cdr (assoc 420 tmp)))) (LM:True->ACI val) )
                    ( (cdr (assoc 62 tmp)) )
                  )
                )
              )
            )
          )
        )
      )
      "    )"
      (cond (def (vl-prin1-to-string def)) ("nil"))
      "  )"
      ")"
    )
  )
)



; This one is assembled by Grrr from Lee Mac's subfunctions here and there...
'(67 114 101 100 105 116 115 32 116 111 32 76 101 101 32 77 97 99)
(defun CreateLayer ( name colour linetype lineweight plot transparency makecurrent / rtn )
  (regapp "accmtransparency")
  (if (not (tblobjname "LAYER" name))
    (setq rtn
      (entmake 
        (append
          '((0 . "LAYER")(100 . "AcDbSymbolTableRecord")(100 . "AcDbLayerTableRecord")(70 . 0))
          (list (cons 2 name) (cons 6 (if (tblsearch "LTYPE" linetype) linetype "Continuous")) )
          colour
          (list (cons 290 (if plot 1 0)) (cons 370 lineweight) )
          (if transparency
            (list (list -3 (list "accmtransparency" (cons 1071 ( (lambda ( x ) (logior (fix (* 2.55 (- 100 x))) 33554432)) transparency ))))) 
          )
        )
      ) 
    )
  )
  (if makecurrent (setvar 'clayer name)) rtn
)



;; True -> ACI  -  Lee Mac
;; Args: c - [int] True Colour

(defun LM:True->ACI ( c / o r )
  (apply 'LM:RGB->ACI (LM:True->RGB c))
)



;; RGB -> ACI  -  Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values

(defun LM:RGB->ACI ( r g b / c o )
  (if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
    (progn
      (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
      (vlax-release-object o)
      (if (vl-catch-all-error-p c)
        (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
        c
      )
    )
  )
)


;; True -> RGB  -  Lee Mac
;; Args: c - [int] True Colour

(defun LM:True->RGB ( c )
  (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24))
)


;; Application Object  -  Lee Mac
;; Returns the VLA Application Object

(defun LM:acapp nil
  (eval (list 'defun 'LM:acapp 'nil (vlax-get-acad-object)))
  (LM:acapp)
)

Hi grrr. Your lisp was great but wont work for me. I get this error message: "Error: bad argument type: fixnump: nil". How can ı fix this?

January 11, 2019

1 hour ago, veteranus said:

Hi grrr. Your lisp was great but wont work for me. I get this error message: "Error: bad argument type: fixnump: nil". How can ı fix this?

Hi,

Unfortunately I'm not able to replicate the error you have.. so you could assist by:

1. Copy the code from the forum

2. Run AutoCAD and type in VLIDE

3. In the Visual lisp Console paste the code

4. Click on debug->break on error

5. Then go to the drawing window and type in the command TEST in order to reproduce the error

If the error is triggered then VLIDE should pop-up highlighting the problematic evaluation of the routine - so we'd know wheres the problem.

BTW heres a picture

January 11, 2019

20 minutes ago, Grrr said:

Hi,

Unfortunately I'm not able to replicate the error you have.. so you could assist by:

1. Copy the code from the forum

2. Run AutoCAD and type in VLIDE

3. In the Visual lisp Console paste the code

4. Click on debug->break on error

5. Then go to the drawing window and type in the command TEST in order to reproduce the error

If the error is triggered then VLIDE should pop-up highlighting the problematic evaluation of the routine - so we'd know wheres the problem.

BTW heres a picture

It worked sir, thank you very much for your effort.

March 27, 2023

Last week the lisp worked perfect. But from now on it won't work anymore.

newlayer : dialog {
: spacer { height = 1;}
: text { alignment = left; label = "Enter Layer Name";}
: edit_box {alignment = left; key = "name"; edit_width = 40;}
: spacer { height = 1;}
ok_cancel;
errtile;}
Error: bad argument type: streamp nil

What is the solution to let this work again?

NewLayer v1.02.lsp

Sign In

Create new layer LISP

Recommended Posts

drdownload18

drdownload18

hanhphuc

Grrr

Stefan BMR

Grrr

Stefan BMR

hanhphuc

Grrr

rlx

veteranus

Grrr

veteranus

bartdheere

Join the conversation

Tutorials

Forums

Activity