« previous next »
Pages: [1] |   Go Down

Author Topic: Need fresh eyes for this lisp  (Read 1413 times)

0 Members and 1 Guest are viewing this topic.

HasanCAD

  • Swamp Rat
  • Posts: 1422
Need fresh eyes for this lisp
« on: November 27, 2016, 07:17:35 AM »
Hi all
I want to rename this block then move to new layer
New Name is "BOTANICAL NAME"
and adding the code as suffix for a new layer
The lisp runs OK for one time then gives an error
Code - Auto/Visual Lisp: [Select]
  1. Select New name for Block:
  2. Select Code: ; error: Automation Error. Key not found

The Code
Code - Auto/Visual Lisp: [Select]
  1. (defun c:RNB (/ a b blk blknm c code d e newblknm newly oldblknm vl-blk )
  3.  
  4.   (while
  5.     (if (setq blk (car (entsel  "\nSelect Block: ")))
  6.       (progn
  7.         (setq VL-Blk (vlax-ename->vla-object blk))
  8.         (setq OldBLkNM (vla-get-Name VL-Blk))
  9.         (SETQ NewBlkNm (VLA-GET-TEXTSTRING (_value "\nSelect New name for Block: ")))  
  10.         (setq NewLy (strcat "L-PLNT-TREE-" (VLA-GET-TEXTSTRING (_value "\nSelect Code: "))))
  11.         (mapcar '(lambda ( a b c d e ) (MakeLayer a b "Continuous" c d 0 e ))
  12.                 (list NewLy)
  13.                 '(82)
  14.                 '(0.13)
  15.                 '(nil)
  16.                 (list (strcat "TREES TYPE " NewBlkNm))
  17.                 )
  18.         (if (equal OldBLkNM NewBlkNm)
  19.           (vlax-put-property VL-Blk 'layer NewLy)
  20.           (progn
  21.             (vlax-put-property VL-Blk 'layer NewLy)
  22.             (vlax-put-property VL-Blk 'name NewBlkNm)
  23.             )
  24.           )
  25.         )
  26.       )
  27.     )
  28.   )
  29.  
  30.  
  31. (defun _value   (str / )
  32.   (while
  33.     (not
  34.       (if (and (setq entt (nentsel str))
  35.                (setq ATTr (car entt))
  36.                (member (vla-get-objectname (setq ATTr (vlax-ename->vla-object ATTr)))
  37.                        '("AcDbAttribute" "AcDbText" "*DIM*" "AcDbMText")))
  38.         ATTr (progn (princ str) nil))))
  39.   ATTr
  40.   )
  41.  
  42. (defun MakeLayer ( name colour linetype lineweight willplot bitflag description )    ;; © Lee Mac 2010
  43.   (regapp "AcAecLayerStandard")
  44.     ;; (MakeLayer name colour linetype lineweight willplot bitflag description )
  45.     ;; Specifications:
  46.     ;; Description        Data Type        Remarks
  47.     ;; -----------------------------------------------------------------
  48.     ;; Layer Name          STRING          Only standard chars allowed
  49.     ;; Layer Colour        INTEGER         may be nil, -ve for Layer Off, Colour < 256
  50.     ;; Layer Linetype      STRING          may be nil, If not loaded, CONTINUOUS.
  51.     ;; Layer Lineweight    REAL            may be nil, 0 <= x <= 2.11
  52.     ;; Plot?               BOOLEAN         T = Plot Layer, nil otherwise
  53.     ;; Bit Flag            INTEGER         0=None, 1=Frozen, 2=Frozen in VP, 4=Locked
  54.     ;; Description         STRING          may be nil for no description
  55.     ;; Function will return list detailing whether layer creation is successful.
  56.  
  57.   (or (tblsearch "LAYER" name)
  58.     (entmake
  59.       (append
  60.         (list
  61.           (cons 0       "LAYER")
  62.           (cons 100     "AcDbSymbolTableRecord")
  63.           (cons 100     "AcDbLayerTableRecord")
  64.           (cons 2       name)
  65.           (cons 70      bitflag)
  66.           (cons 290     (if willplot 1 0))
  67.           (cons 6       (if (and linetype (tblsearch "LTYPE" linetype)) linetype "CONTINUOUS"))
  68.           (cons 62      (if (and colour (< 0 (abs colour) 256)) colour 7))
  69.           (cons 370     (fix (* 100 (if (and lineweight (<= 0.0 lineweight 2.11)) lineweight 0.0))))
  70.           )
  71.         (if description (list (list -3 (list "AcAecLayerStandard" (cons 1000 "") (cons 1000 description)))))
  72.         ))))

Thanks
Logged

HasanCAD

  • Swamp Rat
  • Posts: 1422
Re: Need fresh eyes for this lisp
« Reply #1 on: November 27, 2016, 07:55:43 AM »
I removed IF after while
it is working well put for several time then gives the same error
Code - Auto/Visual Lisp: [Select]
  1. Select Code: ; error: Automation Error. Key not found

Code - Auto/Visual Lisp: [Select]
  1. (defun c:RNB (/ a b blk blknm c code d e newblknm newly oldblknm vl-blk )
  3.  
  4.   (while
  5.     (setq blk (car (entsel  "\nSelect Block: ")))
  6.     (setq VL-Blk (vlax-ename->vla-object blk))
  7.     (setq OldBLkNM (vla-get-Name VL-Blk))
  8.     (SETQ NewBlkNm (VLA-GET-TEXTSTRING (_value "\nSelect New name for Block: ")))
  9.     (setq NewLy (strcat "L-PLNT-TREE-" (VLA-GET-TEXTSTRING (_value "\nSelect Code: "))))
  10.     (mapcar '(lambda ( a b c d e ) (MakeLayer a b "Continuous" c d 0 e ))
  11.             (list NewLy)
  12.             '(82)
  13.             '(0.13)
  14.             '(nil)
  15.             (list (strcat "TREES TYPE " NewBlkNm))
  16.             )
  17.     (if (equal OldBLkNM NewBlkNm)
  18.       (vlax-put-property VL-Blk 'layer NewLy)
  19.       (progn
  20.         (vlax-put-property VL-Blk 'layer NewLy)
  21.         (vlax-put-property VL-Blk 'name NewBlkNm)
  22.         )
  23.       )
  24.     )
  25.   )
  26.  
  27. (defun _value   (str / )
  28.   (while
  29.     (not
  30.       (if (and (setq entt (nentsel str))
  31.                (setq ATTr (car entt))
  32.                (member (vla-get-objectname (setq ATTr (vlax-ename->vla-object ATTr)))
  33.                        '("AcDbAttribute" "AcDbText" "*DIM*" "AcDbMText")))
  34.         ATTr (progn (princ str) nil))))
  35.   ATTr
  36.   )
  37.  
  38. (defun MakeLayer ( name colour linetype lineweight willplot bitflag description )    ;; © Lee Mac 2010
  39.   (regapp "AcAecLayerStandard")
  40.     ;; (MakeLayer name colour linetype lineweight willplot bitflag description )
  41.     ;; Specifications:
  42.     ;; Description        Data Type        Remarks
  43.     ;; -----------------------------------------------------------------
  44.     ;; Layer Name          STRING          Only standard chars allowed
  45.     ;; Layer Colour        INTEGER         may be nil, -ve for Layer Off, Colour < 256
  46.     ;; Layer Linetype      STRING          may be nil, If not loaded, CONTINUOUS.
  47.     ;; Layer Lineweight    REAL            may be nil, 0 <= x <= 2.11
  48.     ;; Plot?               BOOLEAN         T = Plot Layer, nil otherwise
  49.     ;; Bit Flag            INTEGER         0=None, 1=Frozen, 2=Frozen in VP, 4=Locked
  50.     ;; Description         STRING          may be nil for no description
  51.     ;; Function will return list detailing whether layer creation is successful.
  52.  
  53.   (or (tblsearch "LAYER" name)
  54.     (entmake
  55.       (append
  56.         (list
  57.           (cons 0       "LAYER")
  58.           (cons 100     "AcDbSymbolTableRecord")
  59.           (cons 100     "AcDbLayerTableRecord")
  60.           (cons 2       name)
  61.           (cons 70      bitflag)
  62.           (cons 290     (if willplot 1 0))
  63.           (cons 6       (if (and linetype (tblsearch "LTYPE" linetype)) linetype "CONTINUOUS"))
  64.           (cons 62      (if (and colour (< 0 (abs colour) 256)) colour 7))
  65.           (cons 370     (fix (* 100 (if (and lineweight (<= 0.0 lineweight 2.11)) lineweight 0.0))))
  66.           )
  67.         (if description (list (list -3 (list "AcAecLayerStandard" (cons 1000 "") (cons 1000 description)))))
  68.         ))))
« Last Edit: November 27, 2016, 08:27:15 AM by HasanCAD »
Logged

Grrr1337

  • Swamp Rat
  • Posts: 812
Re: Need fresh eyes for this lisp
« Reply #2 on: November 27, 2016, 08:12:16 AM »
The first thing I noticed:
Code: [Select]
(setq OldBLkNM (vla-get-Name VL-Blk))change to:
Code: [Select]
(setq OldBLkNM (vla-get-EffectiveName VL-Blk))
EDIT: Btw whats that _value function? I'm a bad reader, sorry.

Instead of:
Code: [Select]
(SETQ NewBlkNm (VLA-GET-TEXTSTRING (_value "\nSelect New name for Block: ")))
(setq NewLy (strcat "L-PLNT-TREE-" (VLA-GET-TEXTSTRING (_value "\nSelect Code: "))))
I would suggest:
Code: [Select]
(setq NewBlkNm (getV "\nSelect New name for Block: "))
(setq NewLy (strcat "L-PLNT-TREE" (getV "\nSelect Code: ")))

with:
Code: [Select]
(defun getV ( msg / e txt )
(setvar 'errno 0)
(while (/= 52 (getvar 'errno))
(setq e (car (nentsel msg)))
(cond
((= 7 (getvar 'errno)) (princ "\nMissed.") (setvar 'errno 0))
((/= (member (cdr (assoc 0 (entget e))) '("TEXT" "MTEXT" "ATTRIB")))
(princ "\nInvalid object.")
)
((and e (not (snvalid (setq txt (cdr (assoc 1 (entget e)))))))
(princ "\nInvalid content.") (setq txt nil)
)
(txt (setvar 'errno 52))
(T nil)
); cond
); while
(if txt txt "")
); defun
EDIT2:
Also change this part:
Code: [Select]
(if (equal OldBLkNM NewBlkNm)
(vlax-put-property VL-Blk 'layer NewLy)
(progn
(vlax-put-property VL-Blk 'layer NewLy)
(vlax-put-property VL-Blk 'name NewBlkNm)
)
)To:
Code: [Select]
(if (equal OldBLkNM NewBlkNm)
(vlax-put-property VL-Blk 'layer NewLy)
(progn
(vlax-put-property VL-Blk 'layer NewLy)
(vlax-put-property
(vla-item
(vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-get-EffectiveName VL-Blk)
)
'Name
NewBlkNm
)
)
)
« Last Edit: November 27, 2016, 08:35:52 AM by Grrr1337 »
Logged
(apply ''((a b c)(a b c))
  '(
    (( f L ) (apply 'strcat (f L)))
    (( L ) (if L (cons (chr (car L)) (f (cdr L)))))
    (72 101 108 108 111 32 87 111 114 108 100)
  )
)
vevo.bg

HasanCAD

  • Swamp Rat
  • Posts: 1422
Re: Need fresh eyes for this lisp
« Reply #3 on: November 28, 2016, 04:15:54 AM »
Thanks Grrr1337 for your quick reply
getV not working
But the lisp working perfect
Logged
Pages: [1] |   Go Up
« previous next »