Tony,
Any chance you would post the code for your implode routine?
Cheers
Paul
I have written a program to convert all matching trees drawn as individual circles or polylines to blocks.
It would be easy to get it to work with other entities. It does have limitations and needs a bit of tidying up.
When I get time I would like it to improve it to match different scales in one go. When selecting a tree canopy it cannot be partially off the screen.
Here is the code and a test drawing.
;; --=={ treeHUGGER.LSP }==-- ;;
;; ;;
(defun C:TH ()
(c:treeHUGGER)
)
;; --=={ Main Program }==-- ;;
(defun C:treeHUGGER (/ canopyENTNAME GetSSofmatchingCanopy matchingITEMS ReferenceDATA SourceEntityLIST bufferSELECTIONSET adoc acsp FLTR)
(vl-load-com)
(setvar "cmdecho" 0)
(setvar "osmode" 0)
(setvar "ucsicon" 0)
(setvar "lunits" 2)
(setvar "insunits" 0)
(setq newBLOCKlayer (getvar "clayer"))
(setq matchingITEMS 0)
(setq ReferenceDATA nil)
(or adoc (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(or acsp (setq acsp (vla-get-block (vla-get-activelayout adoc))))
(command "ucs" "world")
(Setq FLTR '((0 . "CIRCLE")))
(PRINC "\nPlease select circle representing canopy of tree to convert\n")
(setq canopyENTNAME (acet-ui-single-select FLTR T))
(if (not (wcmatch (vla-get-objectname (setq canopyOBJ (vlax-ename->vla-object canopyENTNAME))) "AcDbCircle"))
(princ "\nInvald selection\n")
(progn
(setq LOOP T)
(while LOOP
(setq BLK (getstring t (strcat "\nEnter the name of the block to create: ")))
(setq BLK (xstrcase BLK))
(cond
((not (snvalid BLK))
(princ "\nInvalid block name.")
)
((tblobjname "BLOCK" BLK)
(princ (strcat "\nBlock " BLK " already exists."))
(initget "Yes" 128)
(if (= (getkword "\nRedefine it? <N>") "Yes")
(setq LOOP nil)
)
)
(T
(setq LOOP nil)
)
)
)
(princ "\nAnalysing tree geometry")
(getGEOMETRY_function)
(command "-layer" "set" "0" "")
(command "chprop" bufferSELECTIONSET "" "LAYER" "0" "")
(command "chprop" canopyENTNAME "" "LAYER" "0" "")
(command "-block" BLK canopyCENTRE canopyENTNAME bufferSELECTIONSET "")
(command "-layer" "set" newBLOCKlayer "")
(command "-insert" blk canopyCENTRE "" "" "")
)
)
(setq ReferenceDATA SourceEntityLIST
SourceEntityLIST nil
)
(command "ucs" "world")
(setq GetSSofmatchingCanopy (ssget "X" canopyINFO))
(command "zoom" "extents");ESSENTIAL
(princ "\nLocating similar tree geometry")
(setq cntr 0)
(while (< cntr (sslength GetSSofmatchingCanopy))
(setq canopyENTNAME (ssname GetSSofmatchingCanopy cntr))
(if (not (wcmatch (vla-get-objectname (setq canopyOBJ (vlax-ename->vla-object canopyENTNAME))) "AcDbCircle"))
(princ "")
(progn
(getGEOMETRY_function)
(if (equal ReferenceDATA SourceEntityLIST 0.01)
(progn
(mapcar '(lambda (ent) (vla-Delete (vlax-ename->vla-object Ent)))
(vl-remove-if-not '(lambda (x) (= (type x) 'ename)) (mapcar 'cadr (ssnamex bufferSELECTIONSET))))
(entdel canopyENTNAME)
(command "-insert" blk canopyCENTRE "" "" "")
(setq matchingITEMS (+ 1 matchingITEMS))
)
)
)
)
(setq cntr (1+ cntr))
)
(setvar "ucsicon" 3)
(PRINC (STRCAT "\nThe selected tree and " (itoa matchingITEMS) " matching tree symbols"))
(PRINC (STRCAT "\nhave been replaced with block " BLK " on the current layer\n"))
(princ)
)
;; --=={ Sub-Functions }==-- ;;
(defun bufferPOINTS_function (obj num / div bufferPOINTS)
(setq div (/ (vlax-curve-getendparam obj) num)
bufferPOINTS (cons (vlax-curve-getpointatparam obj (vlax-curve-getstartparam obj)) bufferPOINTS)
)
(while (> num 1)
(setq bufferPOINTS (cons (vlax-curve-getpointatparam obj (* (1- num) div)) bufferPOINTS)
num (1- num)
)
)
bufferPOINTS
)
(defun getGEOMETRY_function (/ ssSourcetree)
(command "ucs" "w")
(setq canopyCENTRE (vlax-get canopyOBJ 'center)
CanopyRADIUS (vlax-get canopyOBJ 'radius)
CanopyLAYER (vlax-get canopyOBJ 'layer)
CanopyINFO (list (cons 0 "CIRCLE") (cons 8 CanopyLAYER) (cons 40 CanopyRADIUS))
circleBUFFER (vla-addcircle acsp (vlax-3d-point canopyCENTRE) (* 1.01 CanopyRADIUS))
bufferPOINTS (bufferPOINTS_function circleBUFFER 32)
bufferSELECTIONSET (ssget "_WP" bufferPOINTS (list (cons 8 CanopyLAYER )))
SourceCanopyLIST (list "CANOPY" " | Canopy Layer: " CanopyLAYER " | Canopy Radius: " CanopyRADIUS )
SourceEntityLIST (list SourceCanopyLIST)
)
(if (ssmemb canopyENTNAME bufferSELECTIONSET)
(ssdel canopyENTNAME bufferSELECTIONSET)
);remove canopy from bufferSELECTIONSE
(ProcessENTITIES_function)
(vla-delete circleBUFFER)
(princ)
)
(Defun ProcessENTITIES_function ()
(setq PEcntr 0)
(while (< PEcntr (sslength bufferSELECTIONSET))
(setq sel_ent (ssname bufferSELECTIONSET PEcntr)
sel_objtype (vla-get-objectname (setq sel_obj (vlax-ename->vla-object sel_ent)))
)
(cond
((= sel_objtype "AcDbCircle")(ProcessCIRCLE_function))
((= sel_objtype "AcDbPolyline")(ProcessPLINE_function))
((= sel_objtype "AcDbLine")(princ "\nLine selected"))
((= sel_objtype "AcDbPoint")(princ "\nPoint selected"))
((= sel_objtype "AcDbHatch")(princ "\nHatch selected"))
((= sel_objtype "AcDbArc")(princ "\nArc selected"))
((= sel_objtype "AcDbInsert")(princ "\nBlock selected"))
(princ (strcat "\n" sel_obj " selected"))
(princ "")
)
(setq PEcntr (1+ PEcntr))
)
)
(defun ProcessPLINE_function ()
(setq EntityLAYER (vlax-get-property sel_obj 'Layer)
EntityCLOSED? (vlax-get-property sel_obj 'closed)
)
(if (= EntityCLOSED? :vlax-false)
(setq EntityCLOSED? "No");open
(setq EntityCLOSED? "Yes");closed
)
(setq EntityCOORDS (getlwpolyDATA_function sel_obj))
(command "ucs" "or" canopyCENTRE);set UCS to centre of canopy
(setq UCSentitycoords (WCS2UCS_function entitycoords); convert coordinates of polyline from World to current UCS
EntityINFO (List sel_objtype " | Layer = " EntityLayer " | Coordinates relative to canopy centre = " UCSentitycoords " | Closed polyline? = " Entityclosed?)
)
(command "ucs" "world")
(setq SourceEntityLIST (append SourceEntityLIST (list EntityInfo)))
)
(defun ProcessCIRCLE_function ()
(setq EntityLAYER (vlax-get-property sel_obj 'Layer)
EntityCENTER (vlax-get-property sel_obj 'Center)
EntityRADIUS (vlax-get sel_obj 'radius)
EntityCOORDS (vlax-safearray->list (variant-value EntityCENTER))
)
(command "ucs" "or" canopyCENTRE)
(setq EntityCOORDS (list EntityCOORDS)
UCSentityCOORDS (WCS2UCS_function entityCOORDS)
EntityINFO (List sel_objtype " | Layer = " EntityLAYER " | Coordinates relative to canopy centre = " UCSentityCOORDS " | Radius = " EntityRADIUS )
)
(command "ucs" "world")
(setq SourceEntityLIST (append SourceEntityLIST (list EntityInfo)))
)
(defun WCS2UCS_function (EntityCOORDS / res)
(setq res (mapcar '(lambda (x) (trans x 0 1)) EntityCOORDS))
(if (= 1 (length res))
(car res)
res
)
)
(defun getlwpolyDATA_function (lwpolyOBJ / i)
(setq i -1)
(mapcar '(lambda (coord) (append coord (list (vla-getbulge lwpolyOBJ (setq i (1+ i))))))
(Coordinates->List_function (vla-get-coordinates lwPolyOBJ) 2 ))
)
(defun Coordinates->List_function (array dims / vlist rslt)
(if (eq (type array) 'variant)
(setq array (vlax-variant-value array))
)
(setq vlist (vlax-safearray->list array))
(if (eq dims 2)
(while vlist
(setq rslt (cons (list (car vlist) (cadr vlist)) rslt) vlist (cddr vlist)
)
)
(while vlist
(setq rslt (cons (list (car vlist) (cadr vlist) (caddr vlist)) rslt) vlist (cdddr vlist))))
(reverse rslt)
)
(princ "\nType treeHUGGER or TH to run...")
(princ)