Jump to content

defun to create or update layers not updating them

3dwannab

By 3dwannab
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

3dwannab Experienced

3dwannab

Posted
Posted (edited)

Hi all,

 

I have a program to create circles from one point. It basically helps to draw a survey from running dimensions by entering all those and this spits circles out to those dims.

 

There's a defun I got to create and update layers. The only thing I've added to that is adding a layer description. Here's where I get the defun (It's from @ronjonp ).

 

It this some sort of localisation issue?

 

Anyway, here's my full program below.

 

PROBLEM:

If I change the layer properties (color, linetype or description) the defun doesn't update them when I run my program.

  

(vl-load-com)

(defun c:--LDSurvey_Circles ( / ) (progn (LOAD "3dwannab_Survey_Circles")))

;; -----------------------=={ Survey_Circles }==--------------------------
;; -----------------------------------------------------------------------

;; AUTHOR & ADDITIONAL CODE
;; Author: 3dwannab, Copyright © 2022
;; Credit to ronjonp for the function to create or update layers.

;; ABOUT / NOTES
;; - Creates a set of circles from one chosen point.
;; - Creates a named layer that is coloured, DASHED and doesn't plot with a
;;   layer description.
;; - This is handy for when you are drawing a survey and you have the survey in
;;   running dimensions.
;; - Can also be useful for drawing an inner and outer circle, like a Donut.
;;   Which is unlike the AutoCAD command that creates a thick arced Polyline.

;; USAGE
;; - Fist prompt with ask for the location for all the circles.
;; - Then a prompt will show to enter each of the circles radius' separated by a
;;   space.
;; - For example. Entering '100 200 555' will create 3 circles with those three
;;   circles in the string.

;; FUNCTION SYNTAX
;; Short-cut        CIRS
;; Long-cut         Survey_Circles

;; VERSION          DATE          INFO
;; Version 1.0      26-08-2022    First written

;; TO DO LIST
;; - BUG - Where the layer exists and it changed. Running this program will not
;;   update it.

;; -----------------------------------------------------------------------
;; -----------------------=={ Survey_Circles }==--------------------------

(defun c:CIRS nil (c:Survey_Circles))

(defun c:Survey_Circles ( /
  *error*
  acDoc
  cirRadiuses
  cirRadiusesStr
  layName
  ptCircle
  r
  )

(defun *error* (errmsg)
  (and acDoc (vla-EndUndoMark acDoc))
  (and errmsg
   (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*"))
   (princ (strcat "\n<< Error: " errmsg " >>\n"))
   )
  (vla-StartUndoMark (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object))))
  (princ)
  )

(princ "'CIRS' or 'Survey_Circles' command ran..\n")

;; Start the undo mark here
(setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc))

;; Set up variables
(setq ptCircle (getpoint "Pick a point for the survey circles : "))
(setq cirRadiusesStr (getstring T "Enter the radiuses here separated by spaces : "))

;; Split the string into a list
(setq cirRadiuses (splitStr cirRadiusesStr " " " "))

;; Make a new layer that is green, DASHED and doesn't plot with description
(setq layName "Survey Circles")
(_addOrUpdateLayer layName 100 "DASHED" 0 "Temp layer for survey circles")

;; Loop the cirRadiuses variable
(foreach r cirRadiuses
 (progn
  (entmake
    (list
      '(0 . "circle")
      (cons 8 layName)
      (cons 10 ptCircle)
      (cons 40 r)
      )
    )
  )
 )

(vla-EndUndoMark acDoc)

(*error* nil) (princ)

)

(princ)

;; Help with splitting a string https://www.cadtutor.net/forum/topic/66221-how-to-split-a-string-by-character/?do=findComment&comment=543913
;; str = Input String, d = Delimiter, s = Character to use as the splitter
(defun splitStr ( str d s / )
  (read (strcat "("(vl-string-translate d s str)")"))
  )

;; Creates a new layer or updates an existing one if it exists.
;; Will attempt to load the linetype if found in the acad*.lin file and if the layer exists, it will update the properties.
;; Code by ronjonp, taken from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/create-layer-with-true-color-in-lisp/m-p/7904814#M367339
;; Usage:
;; (_addOrUpdateLayer "NewLayerName" '(69 69 69) "3Dash2" 1 "Description goes here")
;; (_addOrUpdateLayer "NewLayerName2" 169 "3Dash2" 0 "Description goes here")
;; NOTE:
;; The 0 or 1 in examples above is for plot on = 1 or plot off = 0.
;; Modified by 3dwannab on 2022.06.11 to add description to the function.
(defun _addOrUpdateLayer (name color ltype plot desc / _loadlinetype _rgb _setLayDescription d e)
  ;; RJP - 04.03.2018
  ;; Creates or updates a layer
  (defun _rgb (l) (+ (lsh (fix (car l)) 16) (lsh (fix (cadr l)) 8) (fix (caddr l))))
  (defun _loadlinetype (linetype / lt out)
    (cond ((tblobjname "ltype" linetype) t)
      ((setq lt (vla-get-linetypes (vla-get-activedocument (vlax-get-acad-object))))
       (setq out (vl-catch-all-apply
         'vla-load
         (list lt
           linetype
           (findfile (if (= 0 (getvar 'measurement))
             "acad.lin"
             "acadiso.lin"
             )
           )
           )
         )
       )
       (not (vl-catch-all-error-p out))
       )
      )
    )
  ;; _setLayDescription added by 3dwannab on 2022.06.11
  (defun _setLayDescription ( name desc / )
    (setq layerobj (vla-add (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) name))
    (vla-put-description layerobj desc)
    )
  (setq d (apply 'append
   (list (if (setq e (tblobjname "layer" name))
     (entget e '("*"))
     (list '(0 . "LAYER")
       '(100 . "AcDbSymbolTableRecord")
       '(100 . "AcDbLayerTableRecord")
       '(70 . 0)
       )
     )
   (list (cons 2 name)
     (if (listp color)
       (cons 420 (_rgb color))
       (cons 62 color)
       )
     (cons 6
       (if (_loadlinetype ltype)
         ltype
         "continuous"
         )
       )
     (cons 290 plot) ;; 1 = plottable 0 = not=plottable
     )
   )
   )
  )
  (if e
    (entmod d)
    (entmakex d)
    )

  (if name
    (_setLayDescription name desc)
    )

  )

(princ (strcat "\n3dwannab_Survey_Circles.lsp Loaded. Invoke by typing 'CIRS' or 'Survey_Circles'")) (princ)

;; (c:Survey_Circles) ;; Uncomment for quick testing only

;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

 

Edited by 3dwannab
mhupp Grand Master

mhupp

Posted
Posted (edited)

the problem is you need to add an if statement checking if layer exists.  because 

(_addOrUpdateLayer layName 100 "DASHED" 0 "Temp layer for survey circles")

Is "updating" any changes you made back to these settings when you run the lisp.

 

 

change the following. 

;; Make a new layer that is green, DASHED and doesn't plot with description
(setq layName "Survey Circles")
(_addOrUpdateLayer layName 100 "DASHED" 0 "Temp layer for survey circles")
;; Loop the cirRadiuses variable  

update to

;; Make a new layer that is green, DASHED and doesn't plot with description
(if (tblsearch "LAYER" "Survey Circles")
  (progn) ;if existing do nothing aka keep any changes you made
  (_addOrUpdateLayer "Survey Circles" 100 "DASHED" 0 "Temp layer for survey circles") ;only adds layer doesn't "update"
)
;; Loop the cirRadiuses variable

 

Edited by mhupp
3dwannab Experienced

3dwannab

Posted
  • Author
Posted

Thanks mhupp, I want _addOrUpdateLayer to work regardless or whether or not the layer exists as I want to update the properties if the layer exists.

 

Trouble is it's not doing so when I wrap it in my program.

 

It does work when _addOrUpdateLayer is loaded as it's own defun though.

mhupp Grand Master

mhupp

Posted
Posted (edited)

Sorry I misunderstood. rather then building an entget list and using entmod. I just used vla-put to update layer if existing. entmakex if not existing.

  

;; Creates a new layer or updates an existing one if it exists.
;; Will attempt to load the linetype if found in the acad*.lin file and if the layer exists, it will update the properties.
;; Code by ronjonp, taken from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/create-layer-with-true-color-in-lisp/m-p/7904814#M367339
;; Usage:
;; (_addOrUpdateLayer "NewLayerName" '(69 69 69) "3Dash2" 1 "Description goes here")
;; (_addOrUpdateLayer "NewLayerName2" 169 "3Dash2" 0 "Description goes here")
;; NOTE:
;; The 0 or 1 in examples above is for plot on = 1 or plot off = 0.
;; Modified by 3dwannab on 2022.06.11 to add description to the function.
(defun _addOrUpdateLayer (name color ltype plot desc / _loadlinetype _rgb _setLayDescription d e)
  ;; RJP - 04.03.2018
  ;; Creates or updates a layer
  (defun _rgb (l) (+ (lsh (fix (car l)) 16) (lsh (fix (cadr l)) 8) (fix (caddr l))))
  (defun _loadlinetype (linetype / lt out)
    (cond
      ((tblobjname "ltype" linetype) t)
      ((setq lt (vla-get-linetypes (vla-get-activedocument (vlax-get-acad-object))))
             (setq out (vl-catch-all-apply
                         'vla-load
                         (list lt
                               linetype
                           (findfile (if (= 0 (getvar 'measurement))
                                       "acad.lin"
                                       "acadiso.lin"
                                     )
                           )
                         )
                       )
             )
        (not (vl-catch-all-error-p out))
      )
    )
  )
  (if (tblsearch "layer" name)
    (progn
      (setq layerobj (vla-add (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) name))
      (vla-put-Color layerobj color)
      (vla-put-linetype layerobj (if (_loadlinetype ltype) ltype "continuous"))
      (cond
        ((eq plot 0)
             (vla-put-plottable layerobj :vlax-false)
        )
        ((eq plot 1)
             (vla-put-plottable layerobj :vlax-true)
        )
      )
      (vla-put-description layerobj desc)
    )
    (entmakex (list '(0 . "LAYER")
                    '(100 . "AcDbSymbolTableRecord")
                    '(100 . "AcDbLayerTableRecord")
                    '(70 . 0)
                    (cons 2 name)
                    (if (listp color)
                      (cons 420 (_rgb color))
                      (cons 62 color)
                    )
                    (cons 6
                      (if (tblsearch "ltype" ltype)
                        ltype
                        "continuous"
                      )
                    )
                    (cons 290 plot)
                    ;;1 = plottable 0 = not=plottable
              )
    )
  )
)

 

maybe @ronjonp can explain/fix the entmod.

 

 

Edited by mhupp
  • Like 1
3dwannab Experienced

3dwannab

Posted
  • Author
Posted (edited)

Thanks, I guess I should have used that as I didn't quite understand the original code.

 

Here's the working version now: 

(vl-load-com)

(defun c:--LDSurvey_Circles ( / ) (progn (LOAD "3dwannab_Survey_Circles")))

;; -----------------------=={ Survey_Circles }==--------------------------
;; -----------------------------------------------------------------------

;; AUTHOR & ADDITIONAL CODE
;; Author: 3dwannab, Copyright © 2022
;; Credit to ronjonp for the function to create or update layers.

;; ABOUT / NOTES
;; - Creates a set of circles from one chosen point.
;; - Creates a named layer that is coloured, DASHED and doesn't plot with a
;;   layer description.
;; - This is handy for when you are drawing a survey and you have the survey in
;;   running dimensions.
;; - Can also be useful for drawing an inner and outer circle, like a Donut.
;;   Which is unlike the AutoCAD command that creates a thick arced Polyline.

;; USAGE
;; - Fist prompt with ask for the location for all the circles.
;; - Then a prompt will show to enter each of the circles radius' separated by a
;;   space.
;; - For example. Entering '100 200 555' will create 3 circles with those three
;;   circles in the string.

;; FUNCTION SYNTAX
;; Short-cut        CIRS
;; Long-cut         Survey_Circles

;; VERSION          DATE          INFO
;; Version 1.0      2022.06.14    First written

;; TO DO LIST
;; - NA

;; -----------------------------------------------------------------------
;; -----------------------=={ Survey_Circles }==--------------------------

(defun c:CIRS nil (c:Survey_Circles))

(defun c:Survey_Circles ( /
  *error*
  acDoc
  cirRadiuses
  cirRadiusesStr
  layName
  ptCircle
  r
  )

(defun *error* (errmsg)
  (and acDoc (vla-EndUndoMark acDoc))
  (and errmsg
   (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*"))
   (princ (strcat "\n<< Error: " errmsg " >>\n"))
   )
  (vla-StartUndoMark (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object))))
  (princ)
  )

(princ "'CIRS' or 'Survey_Circles' command ran..\n")

;; Start the undo mark here
(setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc))

;; Set up variables
(setq ptCircle (getpoint "Pick a point for the survey circles : "))
(setq cirRadiusesStr (getstring T "Enter the radiuses here separated by spaces : "))

;; Split the string into a list
(setq cirRadiuses (splitStr cirRadiusesStr " " " "))

;; Make a new layer that is green, DASHED and doesn't plot with description
(setq layName "Survey Circles")
(_addOrUpdateLayer layName 100 "DASHED" 0 "Temp layer for survey circles")
;; (_addOrUpdateLayer layName 100 "DASHED" 0)

;; Loop the cirRadiuses variable
(foreach r cirRadiuses
 (progn
  (entmake
    (list
      '(0 . "circle")
      (cons 8 layName)
      (cons 10 ptCircle)
      (cons 40 r)
      )
    )
  )
 )

(vla-EndUndoMark acDoc)

(*error* nil) (princ)

)

(princ)

;; Help with splitting a string https://www.cadtutor.net/forum/topic/66221-how-to-split-a-string-by-character/?do=findComment&comment=543913
;; str = Input String, d = Delimiter, s = Character to use as the splitter
(defun splitStr ( str d s / )
  (read (strcat "("(vl-string-translate d s str)")"))
  )

;; Creates a new layer or updates an existing one if it exists.
;; Will attempt to load the linetype if found in the acad*.lin file and if the layer exists, it will update the properties.
;; Code by ronjonp, taken from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/create-layer-with-true-color-in-lisp/m-p/7904814#M367339
;; Usage:
;; (_addOrUpdateLayer "NewLayerName" '(69 69 69) "3Dash2" 1 "Description goes here")
;; (_addOrUpdateLayer "NewLayerName2" 169 "3Dash2" 0 "Description goes here")
;; NOTE:
;; The 0 or 1 in examples above is for plot on = 1 or plot off = 0.
;; Modified by 3dwannab on 2022.06.11 to add description to the function.
;; Help from mhupp here to get it to update layer if it exists: https://www.cadtutor.net/forum/topic/75414-defun-to-create-or-update-layers-not-updating-them/?do=findComment&comment=596266
(defun _addOrUpdateLayer (name color ltype plot desc / _loadlinetype _rgb _setLayDescription d e)
  ;; RJP - 04.03.2018
  ;; Creates or updates a layer
  (defun _rgb (l) (+ (lsh (fix (car l)) 16) (lsh (fix (cadr l)) 8) (fix (caddr l))))
  (defun _loadlinetype (linetype / lt out)
    (cond
      ((tblobjname "ltype" linetype) t)
      ((setq lt (vla-get-linetypes (vla-get-activedocument (vlax-get-acad-object))))
       (setq out (vl-catch-all-apply
         'vla-load
         (list lt
           linetype
           (findfile (if (= 0 (getvar 'measurement))
             "acad.lin"
             "acadiso.lin"
             )
           )
           )
         )
       )
       (not (vl-catch-all-error-p out))
       )
      )
    )
  (if (tblsearch "layer" name)
    (progn
      (setq layerobj (vla-add (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) name))
      (vla-put-Color layerobj color)
      (vla-put-linetype layerobj (if (_loadlinetype ltype) ltype "continuous"))
      (cond
        ((eq plot 0)
         (vla-put-plottable layerobj :vlax-false)
         )
        ((eq plot 1)
         (vla-put-plottable layerobj :vlax-true)
         )
        )
      (vla-put-description layerobj desc)
      )
    (entmakex (list '(0 . "LAYER")
      '(100 . "AcDbSymbolTableRecord")
      '(100 . "AcDbLayerTableRecord")
      '(70 . 0)
      (cons 2 name)
      (if (listp color)
        (cons 420 (_rgb color))
        (cons 62 color)
        )
      (cons 6
        (if (tblsearch "ltype" ltype)
          ltype
          "continuous"
          )
        )
      (cons 290 plot) ;; 1 = plottable 0 = not plottable
      )
    )
    )
  )

;; (_addlayer "NewLayerName3" '(89 88 88) "Hidden2" 1)
;; (_addlayer "NewLayerName3" 7 "Foo" 0)

(princ (strcat "\n3dwannab_Survey_Circles.lsp Loaded. Invoke by typing 'CIRS' or 'Survey_Circles'")) (princ)

;; (c:Survey_Circles) ;; Uncomment for quick testing only

;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

 

Edited by 3dwannab

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

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

×   Your previous content has been restored.   Clear editor

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

×
 Share
Go to topic listing
×
×
  • Create New...