Jump to content
drdownload18

Create new layer LISP

Recommended Posts

drdownload18

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

 

Share this post


Link to post
Share on other sites
drdownload18



I found a solution.

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

NL.lsp

Share this post


Link to post
Share on other sites
hanhphuc

 

FWIW

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

can be

(not (snvalid str ) )

 

  • Like 1

Share this post


Link to post
Share on other sites
Grrr

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

Share this post


Link to post
Share on other sites
Stefan BMR
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 by Stefan BMR

Share this post


Link to post
Share on other sites
Grrr
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)
)

QuickLayer-VLD_v2.gif

  • Like 1

Share this post


Link to post
Share on other sites
Stefan BMR
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.

  • Like 2

Share this post


Link to post
Share on other sites
hanhphuc
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 :beer:

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

 

 

Share this post


Link to post
Share on other sites
Grrr
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 :beer:

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! :beer:

Unfortunately no, if I correctly tried replicate the problem -

NoBug.gif

 

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.

 

 

Share this post


Link to post
Share on other sites
rlx

@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.

🐉:beer:

Share this post


Link to post
Share on other sites
veteranus
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)
)


QuickLayer-VLD_v2.gif

 

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?

Share this post


Link to post
Share on other sites
Grrr
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

 

break on error VLIDE.jpg

Share this post


Link to post
Share on other sites
veteranus
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

 

break on error VLIDE.jpg

 

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

  • Like 1

Share this post


Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now

×