Author Topic: change lisp from applying to whole drawing to be applied to the selected objects  (Read 3911 times)

0 Members and 1 Guest are viewing this topic.

handasa

  • Newt
  • Posts: 21
greetings every body,
i have this lisp code
Code - Auto/Visual Lisp: [Select]
  1. (defun c:COMBINELAYERS(/ doc blocks blk eo layers lay)
  2. ;CHANGE BY LAYER COLOR TO OVERRIDE COLOR
  3.   ;; Get the ActiveX object of the current dwg
  4.         blocks (vla-get-Blocks doc) ;Get the blocks collection
  5.         layers (vla-get-Layers doc) ;Get the layers collection
  6.   ) ;_ end of setq
  7.  
  8.   ;; Step through all blocks (including Model Space & Layouts)
  9.   (vlax-for blk blocks
  10.     ;; Step through all contained entities in block
  11.     (vlax-for eo blk
  12.       ;; Get the layer the entity is placed on
  13.       (setq lay (vla-Item layers (vla-get-Layer eo)))
  14.       (vla-put-Layer eo (getvar "CLAYER")) ;Change the entity to the current layer
  15.       (if (= (vla-get-Color eo) 256)
  16.         ;;If its colour bylayer, change it to overridden color to match
  17.         (vla-put-Color eo (vla-get-color lay))
  18.       ) ;_ end of if
  19.       (if (= (strcase (vla-get-Linetype eo)) "BYLAYER")
  20.         ;;If its linetype bylayer, change it to overridden linetype to match
  21.         (vla-put-Linetype eo (vla-get-Linetype lay))
  22.       ) ;_ end of if
  23.       (if (= (vla-get-Lineweight eo) -1)
  24.         ;;If its lineweight bylayer, change it to overridden lineweigth to match
  25.         (vla-put-Lineweight eo (vla-get-Lineweight lay))
  26.       ) ;_ end of if
  27.     ) ;_ end of vlax-for
  28.   ) ;_ end of vlax-for
  29.   (princ)
  30. ) ;_ end of defun


which apply its task to the whole drawing objects ..

i need to apply this lisp to the selected objects only


any suggestions ?
thanks in advance  8-)

roy_043

  • Water Moccasin
  • Posts: 1895
  • BricsCAD 18
Welcome to The Swamp.

Try this:
Code - Auto/Visual Lisp: [Select]
  1.  
  2. (defun _Conv_Pickset_To_EnameList (ss / i ret)
  3.   (if ss
  4.     (repeat (setq i (sslength ss))
  5.       (setq ret (cons (ssname ss (setq i (1- i))) ret))
  6.     )
  7.   )
  8. )
  9.  
  10. (defun c:CombineLayers (/ clyr doc lyrs ss)
  11.   (if (setq ss (ssget))
  12.     (progn
  13.       (if (= (logand (getvar 'undoctl) 8) 8)
  14.         (vla-endundomark doc)
  15.       )
  16.       (vla-startundomark doc)
  17.       (setq lyrs (vla-get-layers doc))
  18.       (setq clyr (getvar 'clayer))
  19.       (mapcar
  20.         '(lambda (obj / lyr)
  21.           (setq lyr (vla-item lyrs (vla-get-layer obj)))
  22.           (vla-put-layer obj clyr)
  23.           (if (= 256 (vla-get-color obj))
  24.             (vla-put-color obj (vla-get-color lyr))
  25.           )
  26.           (if (= "BYLAYER" (strcase (vla-get-linetype obj)))
  27.             (vla-put-linetype obj (vla-get-linetype lyr))
  28.           )
  29.           (if (= -1 (vla-get-lineweight obj))
  30.             (vla-put-lineweight obj (vla-get-lineweight lyr))
  31.           )
  32.         )
  33.         (mapcar 'vlax-ename->vla-object (_Conv_Pickset_To_EnameList ss))
  34.       )
  35.       (vla-endundomark doc)
  36.     )
  37.   )
  38.   (princ)
  39. )

handasa

  • Newt
  • Posts: 21
roy,the original lisp apply its effect to blocks sub entities ... the modified one doesn't ...thanks

roy_043

  • Water Moccasin
  • Posts: 1895
  • BricsCAD 18
roy,the original lisp apply its effect to blocks sub entities ... the modified one doesn't ...thanks
Yes, I know but that is what you have asked for:
i need to apply this lisp to the selected objects only

roy_043

  • Water Moccasin
  • Posts: 1895
  • BricsCAD 18
Here is the revised code. Mind that the code does not handle the special behaviour of nested entities on layer "0".
Code - Auto/Visual Lisp: [Select]
  1.  
  2. (defun _Conv_Pickset_To_EnameList (ss / i ret)
  3.   (if ss
  4.     (repeat (setq i (sslength ss))
  5.       (setq ret (cons (ssname ss (setq i (1- i))) ret))
  6.     )
  7.   )
  8. )
  9.  
  10. (defun c:CombineLayers (/ N_Modify cLyrNme blkLst blks doc lyrs ss)
  11.  
  12.   (defun N_Modify (obj / blk lyr)
  13.     (setq lyr (vla-item lyrs (vla-get-layer obj)))
  14.     (vla-put-layer obj cLyrNme)
  15.     (if (= 256 (vla-get-color obj))
  16.       (vla-put-color obj (vla-get-color lyr))
  17.     )
  18.     (if (= "BYLAYER" (strcase (vla-get-linetype obj)))
  19.       (vla-put-linetype obj (vla-get-linetype lyr))
  20.     )
  21.     (if (= -1 (vla-get-lineweight obj))
  22.     )
  23.     (if
  24.       (and
  25.         (vlax-property-available-p obj 'hasattributes)
  26.         (= :vlax-true (vla-get-hasattributes obj))
  27.       )
  28.       (foreach att (vlax-invoke obj 'getattributes)
  29.         (N_Modify att)
  30.       )
  31.     )
  32.     (if
  33.       (and
  34.         (= "AcDbBlockReference" (vla-get-objectname obj))
  35.         (not (vl-position (setq blk (vla-item blks (vla-get-name obj))) blkLst))
  36.       )
  37.       (setq blkLst (append blkLst (list blk)))
  38.     )
  39.   )
  40.  
  41.   (if (setq ss (ssget))
  42.     (progn
  43.       (if (= (logand (getvar 'undoctl) 8) 8)
  44.         (vla-endundomark doc)
  45.       )
  46.       (vla-startundomark doc)
  47.       (setq lyrs (vla-get-layers doc))
  48.       (setq blks (vla-get-blocks doc))
  49.       (setq cLyrNme (getvar 'clayer))
  50.       (foreach obj (mapcar 'vlax-ename->vla-object (_Conv_Pickset_To_EnameList ss))
  51.         (N_Modify obj)
  52.       )
  53.       (while blkLst
  54.         (if (= :vlax-false (vla-get-isxref (car blkLst)))
  55.           (vlax-for obj (car blkLst)
  56.             (N_Modify obj)
  57.           )
  58.         )
  59.         (setq blkLst (cdr blkLst))
  60.       )
  61.       (vla-endundomark doc)
  62.     )
  63.   )
  64.   (princ)
  65. )

handasa

  • Newt
  • Posts: 21
great job ...
that's what i need ...
thanks alot, roy

roy_043

  • Water Moccasin
  • Posts: 1895
  • BricsCAD 18
The code in my previous post could process the same block twice.
New code:
Code - Auto/Visual Lisp: [Select]
  1.  
  2. (defun _Conv_Pickset_To_EnameList (ss / i ret)
  3.   (if ss
  4.     (repeat (setq i (sslength ss))
  5.       (setq ret (cons (ssname ss (setq i (1- i))) ret))
  6.     )
  7.   )
  8. )
  9.  
  10. (defun c:CombineLayers (/ N_Modify cLyrNme blkLst blks doc i lyrs ss)
  11.  
  12.   (defun N_Modify (obj / blk lyr)
  13.     (setq lyr (vla-item lyrs (vla-get-layer obj)))
  14.     (vla-put-layer obj cLyrNme)
  15.     (if (= 256 (vla-get-color obj))
  16.       (vla-put-color obj (vla-get-color lyr))
  17.     )
  18.     (if (= "BYLAYER" (strcase (vla-get-linetype obj)))
  19.       (vla-put-linetype obj (vla-get-linetype lyr))
  20.     )
  21.     (if (= -1 (vla-get-lineweight obj))
  22.     )
  23.     (if
  24.       (and
  25.         (vlax-property-available-p obj 'hasattributes)
  26.         (= :vlax-true (vla-get-hasattributes obj))
  27.       )
  28.       (foreach att (vlax-invoke obj 'getattributes)
  29.         (N_Modify att)
  30.       )
  31.     )
  32.     (if
  33.       (and
  34.         (= "AcDbBlockReference" (vla-get-objectname obj))
  35.         (not (vl-position (setq blk (vla-item blks (vla-get-name obj))) blkLst))
  36.       )
  37.       (setq blkLst (append blkLst (list blk)))
  38.     )
  39.   )
  40.  
  41.   (if (setq ss (ssget))
  42.     (progn
  43.       (if (= (logand (getvar 'undoctl) 8) 8)
  44.         (vla-endundomark doc)
  45.       )
  46.       (vla-startundomark doc)
  47.       (setq lyrs (vla-get-layers doc))
  48.       (setq blks (vla-get-blocks doc))
  49.       (setq cLyrNme (getvar 'clayer))
  50.       (foreach obj (mapcar 'vlax-ename->vla-object (_Conv_Pickset_To_EnameList ss))
  51.         (N_Modify obj)
  52.       )
  53.       (setq i 0)
  54.       (while (< i (length blkLst))
  55.         (if (= :vlax-false (vla-get-isxref (nth i blkLst)))
  56.           (vlax-for obj (nth i blkLst)
  57.             (N_Modify obj)
  58.           )
  59.         )
  60.         (setq i (1+ i))
  61.       )
  62.       (vla-endundomark doc)
  63.     )
  64.   )
  65.   (princ)
  66. )

handasa

  • Newt
  • Posts: 21
a great code ,ROY
THANKS A LOT FOR  YOUR TIME ...

handasa

  • Newt
  • Posts: 21
Code - Auto/Visual Lisp: [Select]
  1. ;Change all TrueColor to AutoCAD Color Index
  2. (defun c:all_to_aci ( / remove420 la e)
  3.   (defun remove420 (entity_list)
  4.     (entmod (vl-remove (assoc 420 entity_list) entity_list))
  5.     )
  6.   (while
  7.     (setq la (tblnext "layer" (not la)))
  8.     (remove420 (entget (tblobjname "layer" (cdr (assoc 2 la)))))
  9.     )
  10.   (while (setq e (if e (entnext e) (entnext)))
  11.     (remove420 (entget e))
  12.   )
  13.   (princ)
  14. )


i want this lisp to be applied to blocks subentities ... can you help me ,roy?

best regards

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

handasa

  • Newt
  • Posts: 21
iam not a lisp developer ... iam just a simple user of them .... can you pleas write this lisp to me ... i don't knew how to use lee mac function as a lisp and don't knew what's the command used to run this lisp

dgorsman

  • Water Moccasin
  • Posts: 2437
A gentle word of advice: coding forums in general aren't a "code house" where others create programs to suit your needs.  They are for assisting those who are trying to understand and write the code.  While you may get some generous posters to provide one or two samples to start with, unless you make an attempt to understand how the code operates you'll quickly find your questions left unanswered.
If you are going to fly by the seat of your pants, expect friction burns.

try {GreatPower;}
   catch (notResponsible)
      {NextTime(PlanAhead);}
   finally
      {MasterBasics;}

handasa

  • Newt
  • Posts: 21
dgorsman,thanks for your gentle advice ...
but iam not a programmer iam an electrical engineer and i do my best to modify my lisps as possible ... but advanced lisps codes i try to understand them by comparison as i have no time to learn programming or coding ...
once someone modify this lisp others who need this lisp will find it and use it ... and others who wants to learn coding or programming will learn too ...
thanks

handasa

  • Newt
  • Posts: 21
btw the developer of the original lisp modified it for me and now it works like a charm
the original thread : http://www.cadtutor.net/forum/showthread.php?88740-Change-especific-True-color-to-especific-ASC-color-by-LISP&p=653868#post653868
Code - Auto/Visual Lisp: [Select]
  1. (defun c:all_to_aci ( / remove420 la en)
  2.   (defun remove420 (entity_list)
  3.     (vl-catch-all-apply '(lambda nil (entmod (vl-remove (assoc 420 entity_list) entity_list))))
  4.     )
  5.   (while
  6.     (setq la (tblnext "layer" (not la)))
  7.     (remove420 (entget (tblobjname "layer" (cdr (assoc 2 la)))))
  8.     )
  9.     (if
  10.       (not (eq (vla-get-isxref block) :vlax-true))
  11.       (vlax-for en block
  12.         (remove420 (entget (vlax-vla-object->ename en)))
  13.         )
  14.       )
  15.     )
  16.   (princ)
  17. )

handasa

  • Newt
  • Posts: 21
hey , roy_043
iam sorry but could you please modify this lisp so that it process the objects not more than one time (texts processed multiple times and the final result isn't the desired one.. thanks in advance

Code: [Select]
;--------code start--------;
(defun get-excel-data (/ ExcData xlApp xlBook xlCell xlRange xlSheet)
  (if (not (setq xlApp (vlax-get-object "Excel.Application")))
    (setq xlApp (vlax-create-object "Excel.Application"))
  )
  (if xlApp
    (progn
      (if
(not
  (vl-catch-all-error-p
    (vl-catch-all-apply
      (function (lambda ()
  (setq
    xlBook (vlax-get-property xlApp "ActiveWorkBook")
  )
)
      )
    )
  )
)
(progn
   (vlax-invoke-method xlBook "Activate")
   (setq xlSheet (vlax-get-property xlBook "ActiveSheet"))
     (if
  (vl-catch-all-error-p
    (vl-catch-all-apply
      (function (lambda ()
  (setq xlRange (vlax-get-property xlApp "Selection"))))))
  (setq xlRange (vlax-get-property xlSheet "UsedRange")))
   
(setq ExcData (vlax-safearray->list
   (vlax-variant-value
     (vlax-get-property xlRange "Value")
   )
)
   ) ;or Value2
   (setq ExcData
  (mapcar (function
    (lambda (x) (mapcar 'vlax-variant-value x))
  )
  ExcData
  )
   )

   (vlax-invoke-method xlApp "Quit")
)
      )
      (mapcar (function (lambda (x)
  (vl-catch-all-apply
    (function (lambda ()
(progn
  (vlax-release-object x)
  (setq x nil)
)
      )
    )
  )
)
      )
      (list xlCell xlRange xlSheet xlBook xlApp)
      )
    )
  )
  (gc)
  ExcData
)
; ------------------------------------------;

(defun newstring (old new str)
(while
(vl-string-search old str)
(setq str (vl-string-subst new old str))))

; ------------------------------------------;
(defun C:FRE ()

(vl-load-com)
(or adoc
    (setq adoc (vla-get-activedocument
(vlax-get-acad-object))))
(or acsp (setq acsp (if (= (getvar "CVPORT") 1)
(vla-get-paperspace
adoc)
(vla-get-modelspace
adoc)
)
)
    )
(vla-endundomark
  adoc)
(vla-startundomark
  adoc)
(setq repList (get-excel-data))
(vla-zoomall (vlax-get-acad-object))
(setq ss (ssget "_X" (list (cons 0 "*TEXT"))))
  (setq axss (vla-get-activeselectionset adoc))
  (vlax-for a axss
    (setq strRep (vlax-get-property a "TextString"))
    (while (vl-some (function (lambda(x)
     (vl-string-search x strRep)))
(mapcar 'car repList))

    (setq newStr
    (car
    (vl-remove-if 'not
    (mapcar (function (lambda(a b)(newstring a b strRep)))
   
    (mapcar 'car repList)(mapcar 'cadr repList)))))
    (setq strRep newStr))
      (vlax-put-property a "TextString" newStr)
       (vla-update a))
 

(vla-endundomark
  adoc)

  (princ)
)

(prompt "\n\t\t  * Type FRE to execute... *")
(princ)

credits for this lisp goes to fixo