AutoLISP: Make More (like ADDSELECTED)

Well. Kent Cooper has done it again… He made this great LISP routine that I like better than the one that is in AutoCAD. The ADDSELECTED command in AutoCAD is pretty cool. You select an object and whatever properties the object has (layer, color, linetype) and the command that created the object will be used to create the new object. The beauty of it is that you do not need to know what tool created the object or what properties are associated with it. This is great for drawings that have a lot of layers and if objects have had their properties changed from something other than BYLAYER.

It’s like ADDSELECTED for versions of AutoCAD prior to 2011!!!!

Kent’s routine is called Make More and works pretty much the same as the ADDSELECTED command. One difference that I should point out is actually its strong point. When you select any type of polyline it will ask you what command you want to use. This is because entities like RECTANGLES and POLYGONS are made of polylines. However, when you use the ADDSELECTED command, and you select a RECTANGLE or POLYGON, it will automatically start the polyline command and will not give you the choice to make a RECTANGLE or POLYGON.

Here’s how to use MAKE MORE:

  • MM <enter> to start
  • Select an object that you want to set the layer, properties and command that made it with your new object.
  • Use whatever command to create the object.

Note: Make More will set the layer current and leave it current for the object that you select.

;; MakeMore.LSP
;; Concept inspired by CADALYST July 2008 www.cadalyst.com Tip 2298:
;; SetAs.lsp -- Make More of the Same (c) 2008 Mosad H. Elewa
;; Thoroughly rewritten from scratch, corrected, expanded & improved by Kent Cooper
;; Last revised March 2011
;http://forums.autodesk.com/t5/Visual-LISP-AutoLISP-and-General/Add-Selected-Create-similar-object-for-ACAD-2007/m-p/2937680
;; To Make More of the same kind of entity as a selected object.
;; Sets all appropriate properties (Layer, Color, Linetype, Linetype Scale, Lineweight, Thickness) to match
;; selected object; leaves them that way, in case User wants to make more than one more matching object.
;; Warns User if any properties other than Layer are different from default, suggesting resetting when done.
;; Invokes the appropriate command to create the same kind of object.
;; Offers choices where entity data alone cannot determine which command to use.
;; Sets matching default values where possible, and/or offers other options, depending on object type [e.g.
;; Offers default where entity data *suggests* a certain command for LWPolylines].
;; Notifies User if selected object is not one that routine can replicate, but still sets its properties.
;; [Note: Using Enter to recall the last command, immediately after drawing something via MM, will
;; recall MM itself; it will not recall the command that MM invoked.]
;
(defun C:MM
(/ *error* cmde obj objdata objtyp mljust c1 c2 c3 plobj parpt equal42 pldata pltypdef plside pltyp dodia
polytyp polymesh regtyp ins-name hXdata dohatch dtyp dbase drot ldrform tsty tht trot tins10 tins11 tjust72
tjust73 tjust1 tjust2 tjust tstyht thtover twd tstylwd twdover lastent tcont tnext tlist tdata tjustno 3Dtyp htyp)
;
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); end if
(setvar 'cmdecho cmde)
); end defun - *error*
;
(vl-load-com)
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(while
(not
(setq obj (entsel "\nSelect object to Make More of the same: "))
); end not
(prompt "\nNothing selected:")
); end while
(setq
objdata (entget (car obj))
objtyp (cdr (assoc 0 objdata))
); end setq
(setvar 'clayer (cdr (assoc 8 objdata)))
(setvar 'cecolor (cond ((assoc 62 objdata) (itoa (cdr (assoc 62 objdata)))) (T "BYLAYER")))
(setvar 'celtype (cond ((cdr (assoc 6 objdata))) (T "BYLAYER")))
(setvar 'celtscale (cond ((cdr (assoc 48 objdata))) (T 1.0)))
(setvar 'celweight (cond ((cdr (assoc 370 objdata))) (T -1)))
(setvar 'thickness (cond ((cdr (assoc 39 objdata))) (T 0)))
; Warning & reset recommendation if certain things are not Bylayer or default:
(if
(or
(/= (strcase (getvar 'cecolor)) "BYLAYER")
(/= (strcase (getvar 'celtype)) "BYLAYER")
(/= (getvar 'celtscale) 1.0)
(/= (getvar 'celweight) -1)
(/= (getvar 'thickness) 0)
); end or
(alert
(strcat
"WARNING: Recommend resetting\n"
(if (/= (strcase (getvar 'cecolor)) "BYLAYER") " Color to Bylayer\n" "")
(if (/= (strcase (getvar 'celtype)) "BYLAYER") " Linetype to Bylayer\n" "")
(if (/= (getvar 'celtscale) 1.0) " Linetype scale to 1\n" "")
(if (/= (getvar 'celweight) -1) " Lineweight to Bylayer\n" "")
(if (/= (getvar 'thickness) 0) " Thickness to 0\n" "")
"when finished."
); end strcat
); end alert
); end if
;
(cond; begin OVERARCHING TEST for each object type
;
((wcmatch objtyp
"LINE,XLINE,RAY,SOLID,3DFACE,ARC,CIRCLE,ELLIPSE,SPLINE,IMAGE,WIPEOUT,TOLERANCE")
(command (strcat "_." objtyp))
); end CATCH-ALL condition for object types whose command names are the same as their 'objtyp' values,
; and which don't need any other information extracted to set variables, nor have other complications
;;;;; pull IMAGE out and offer SUPERHATCH option, perhaps only if part of a Group?
;;;;; pull SOLID,3DFACE,WIPEOUT out and offer TEXTMASK option?
;
;;;;; To offer SKETCH option for Line, if desired, delete "LINE," from catch-all above, delete these two lines,
;;;;; and remove initial semicolons from 10 lines below
; ((= objtyp "LINE")
; (initget "Line Sketch")
; (if (= (getkword "\nCommand option [Line/Sketch] <L>: ") "Sketch")
; (progn ; then
; (setvar 'skpoly 0)
; (command "_.sketch")
; ); end progn - Sketch option
; (command "_.line"); else - ordinary-Line variety
; ); end if - variety of Line
; ); end cond - Line object type
;
((= objtyp "MLINE")
(setq mljust (cdr (assoc 70 objdata)))
(command "_.mline"
"j"
(cond
((= mljust 0) "T")
((= mljust 1) "Z")
((= mljust 2) "B")
); end cond - justification test
"s" (cdr (assoc 40 objdata))
"st" (cdr (assoc 2 objdata))
); end mline command
); end Mline object type
;
((= objtyp "TRACE")
(setq c1 (cdr (assoc 10 objdata)) c2 (cdr (assoc 11 objdata)) c3 (cdr (assoc 12 objdata)))
(setvar 'tracewid; default: perp. distance from 2nd corner to line between 1st and 3rd
(distance; [if trace has been stretched and isn't constant width, this will be off]
c2
(inters c1 c3 c2 (polar c2 (+ (angle c1 c3) (/ pi 2)) 1) nil)
); end distance
); end setvar
(command "_.trace")
); end Trace object type
;
((= objtyp "LWPOLYLINE")
(if (= (getvar 'plinetype) 0) (setvar 'plinetype 2))
; in case set at 0 [old-style "heavy" 2D type]; value of 1 can remain [new ones still lightweight];
; assumes no desire to return it to 0 - add that resetting or option or recommendation, if desired
(if (assoc 43 objdata); has global width
(setvar 'plinewid (cdr (assoc 43 objdata))); then - match it
(setvar 'plinewid 0); else - remove current width if non-zero
); end if
(defun parpt (par); find Point at Parameter for Polyline type tests
(vlax-curve-getPointAtParam plobj par)
); end defun
(defun equal42 (val); find whether *all* bulge factors [(assoc 42) entries] have specified value
(setq pldata objdata)
(while (equal (cdr (assoc 42 pldata)) val 1e-6)
(setq pldata (cdr (member (assoc 42 pldata) pldata))); remainder after this 42 entry
); end while
(not (assoc 42 pldata)); returns T if they were all equal [none left]
); end defun
(setq
plobj (car obj)
plverts (cdr (assoc 90 objdata)); number of vertices for type tests & to set 'polysides
pltypdef ; PolyLine TYPe DEFault
(cond
( (and
(= plverts 4)
(vlax-curve-isClosed plobj)
(assoc 43 objdata); global width
(equal42 0.0); all straight-line segments
(equal (distance (parpt 0) (parpt 1)) (distance (parpt 2) (parpt 3)) 1e-8); opposite sides equal lengths
(equal (distance (parpt 1) (parpt 2)) (distance (parpt 3) (parpt 0)) 1e-8)
(equal (rem (abs (- (angle (parpt 0) (parpt 1)) (angle (parpt 1) (parpt 2)))) pi) (/ pi 2) 1e-8)
; right angle first corner
); end and
"Rectangle"
); end Rectangle condition
;;;;; Works only for four-sided square-cornered Rectangles; there are options, independent of similar options
;;;;; for general drawing: [Chamfer/Elevation/Fillet/Thickness/Width].
;;;;; Polyline with 8 vertices, 2nd & 6th segments same length, 4th & 8th segments same length, odd-numbered
;;;;; ones all same length, could be Rectangle with Chamfer or Fillet option. If odd-numbered segments have
;;;;; (42 . 0.414214), Fillet [90-degree arc bulge factor]. If (equal42 0.0), Chamfer.
;;;;; ***Don't know where those options are stored, or how to set them as defaults programmatically.***
( (and
(> plverts 2)
(vlax-curve-isClosed plobj)
(member '(43 . 0.0) objdata); global width = 0
(equal42 0.0); all straight-line segments
(equal ; first two and last two segments, at least, all same length
(setq plside (distance (parpt 0) (parpt 1))); first segment length
(distance (parpt 1) (parpt 2)); second
1e-8
); end equal
(equal (distance (parpt (- plverts 2)) (parpt (1- plverts))) plside 1e-8); next-to-last
(equal (distance (parpt (1- plverts)) (parpt 0)) plside 1e-8); last
); end and
"POlygon"
); end POlygon condition [does not check for equal angles]
( (and
(= plverts 2)
(vlax-curve-isClosed plobj)
(assoc 43 objdata); global width, but only:
(not (member '(43 . 0.0) objdata)); if non-zero
(equal42 1.0); all full-semi-circle arc segments
); end and
"Donut"
); end Donut condition
( (and
(vlax-curve-isClosed plobj)
(assoc 43 objdata)
(equal42 0.520567); all Revcloud-type arc segments
); end and
"Cloud"
); end Cloud condition
(T "PLine"); none of the above [no default offering for Boundary or Sketch]
); end cond & pltypdef
); end setq
(initget "PLine Rectangle POlygon Donut Cloud Boundary Sketch")
(setq
pltyp
(getkword
(strcat
"\nPolyline Type [PLine/Rectangle/POlygon/Donut/Cloud/Boundary/Sketch] <"
pltypdef
">: "
); end strcat
); end getkword
pltyp (if pltyp pltyp pltypdef); use User entry, or default for Enter
); end setq
(cond; variety of Polyline
((= pltyp "Rectangle")
(command "_.rectangle" "w" (getvar 'plinewid))
); end Rectangle variety
((= pltyp "POlygon")
(setvar 'polysides (if (> plverts 2) plverts 4))
(setvar 'cmdecho 1)
(command "_.polygon")
(while (> (getvar 'cmdactive) 0) (command pause))
(vlax-put (vlax-ename->vla-object (entlast)) 'ConstantWidth (getvar 'plinewid))
; Polygon doesn't honor width -- assign current [selected item's] width to new Polygon
); end POlygon variety
((= pltyp "Donut")
(setq dodia; donut diameter at centerline
(distance (vlax-curve-getStartPoint plobj) (vlax-curve-getPointAtParam plobj 1))
); end setq
(setvar 'donutid (- dodia (getvar 'plinewid)))
(setvar 'donutod (+ dodia (getvar 'plinewid)))
(command "_.donut")
); end Donut variety
((= pltyp "Cloud") (command "_.revcloud"))
;;;;; Are arc min/max lengths determinable from objdata?
((= pltyp "Boundary")
(setvar 'hpbound 1)
(command "_.boundary")
); end Boundary variety
((= pltyp "Sketch")
(setvar 'skpoly 1)
(command "_.sketch")
); end Sketch variety
(T (command "_.pline")); ordinary-PLine variety
); end cond - variety of LWPoly
); end cond - LWPoly object type
;
((= objtyp "POLYLINE")
(setq polytyp (substr (cdr (assoc 100 (cdr (member (assoc 100 objdata) objdata)))) 5))
; *second* 100 value minus "AcDb" prefix
(cond
((= polytyp "3dPolyline") (command "_.3dpoly"))
((= polytyp "2dPolyline")
(initget "Heavy Lightweight")
(if (= (getkword "\nMatch old Heavy 2D type, or use new Lightweight type? [H/L] <L>: ") "Heavy")
(progn; then - old-style "heavy" 2D type
(setvar 'plinetype 0)
(alert "Recommend resetting the PLINETYPE\nSystem Variable to 1 or 2 when finished.")
; but doesn't save it and reset it, in case User needs to make more than one of them
(command "_.pline")
); end progn
(progn ; else - newer-style "lightweight" type
(if (zerop (getvar 'plinetype)) (setvar 'plinetype 2))
; in case it was set at 0 [old-style "heavy" 2D type];
; value of 1 can remain [new ones still lightweight];
; assumes no desire to return it to 0 - add that resetting or option or recommendation, if desired
(command "_.pline")
); end progn
); end if
); end second condition - 2dPolyline type
((= polytyp "PolygonMesh"); [couldn't find a way to differentiate types from entity data]
(initget "3D 3DMesh Pface REvsurf RUlesurf Tabsurf")
(setq polymesh (getkword
"\nPolygon Mesh command [3D/3DMesh/Pface/REvsurf/RUlesurf/Tabsurf] <3D>: "))
(if (or (not polymesh) (= polymesh "3D")); user hit Enter or typed 3D
(3d x); then - use default [don't know why it works this way, and not in (command) function]
(command (strcat "_." polymesh)); else - other entered option
); end if
); end third condition - mesh types
); end cond - variety of polyline
); end 3D/heavy 2D Polyline object type
;
((= objtyp "REGION")
(initget "Objects Boundary Section")
(setq regtyp (getkword "Region source [Objects/Boundary/Section] <O>: "))
(cond
((= regtyp "Boundary")
(setvar 'hpbound 0)
(command "_.boundary")
); end Boundary-defined region source
((= regtyp "Section") (command "_.section"))
(T (command "_.region"))
); end if - region source
); end Region object type
;
((= objtyp "INSERT"); overall Block/Minsert/Xref/Metafile/Light/old-style Hatch category
;;;;; offer SUPERHATCH option, perhaps only if part of a Group?
(setq ins-name (cdr (assoc 2 objdata)))
(cond
((= (substr ins-name 1 2) "*X"); identify old-style Hatch pattern
(setq hXdata (cddadr (assoc -3 (entget (car obj) '("ACAD"))))); extended data
(setvar 'hpname (cdr (assoc 1000 hXdata)))
(setvar 'hpscale (cdr (assoc 1040 hXdata)))
(setvar 'hpang (cdr (assoc 1040 (cddddr hXdata)))); second 1040 = rotation in radians
(if (= (getvar 'hpname) "_U"); User-defined
(progn
(setvar 'hpspace (cdr (assoc 1040 hXdata)))
(setvar 'hpdouble (cdr (assoc 1070 (cddddr hXdata)))); double-direction
); end progn
); end if
(setq dohatch T); picked up by later (if) after overall object-type (cond) is done; also with Hatch object type
); end old-style Hatch variety
((= (logand 4 (cdr (assoc 70 (tblsearch "block" (cdr (assoc 2 objdata)))))) 4); identify Xref
(initdia)
(command "_.xref")
); end Xref variety
;;;;; XCLIP option? identifiable from entity data?
((= (substr ins-name 1 3) "WMF"); identify Windows Metafile [if it hasn't been renamed]
(command "_.wmfin")
); end Metafile variety
((wcmatch ins-name "direct,overhead,sh_spot"); identify Light [assuming names not used otherwise]
(command "_.light")
); end Light variety
(T; Minsert or ordinary Block [both need next line]
(setvar 'insname ins-name)
(if (= (cdr (assoc 100 (cdr (member (assoc 100 objdata) objdata)))) "AcDbMInsertBlock")
; identify Minsert by *second* 100 value
(command "_.minsert"); then
(progn (initdia) (command "_.insert")); else - ordinary Block
;;;;; offer Divide & Measure options?
); end if - Minsert or Block option
); end Minsert/Block variety
); end cond - variety of Insert
); end Insert object type
;
((= objtyp "SHAPE")
(setvar 'shpname (cdr (assoc 2 objdata)))
(command "_.shape")
); end Shape object type
;
((= objtyp "HATCH")
(setvar 'hpname (cdr (assoc 2 objdata))); hatch pattern
(if (wcmatch (getvar 'hpname) "U,_USER")
(progn
(setvar 'hpspace (cdr (assoc 41 objdata)))
(setvar 'hpdouble (cdr (assoc 77 objdata)))
); end progn
); end if
(if (/= (getvar 'hpname) "SOLID")
(progn
(setvar 'hpscale (cdr (assoc 41 objdata)))
(setvar 'hpang (cdr (assoc 52 objdata)))
); end progn
); end if
(setvar 'hpassoc (cdr (assoc 97 objdata)))
(setq dohatch T); picked up by later (if) after overall object-type (cond) is done; also with Insert old-style Hatch object type
); end Hatch object type
;
((= objtyp "DIMENSION")
(command "_.dimstyle" "r" (cdr (assoc 3 objdata)))
(setvar 'cecolor "bylayer"); dimensions do not honor color overrides
(setq dtyp (cdr (assoc 70 objdata)))
(setq dXdata (cadr (assoc -3 (entget (car obj) '("ACAD"))))); extended data
(setvar 'dimse1 (if (member '(1070 . 75) dXdata) (cdadr (member '(1070 . 75) dXdata)) 0))
(setvar 'dimse2 (if (member '(1070 . 76) dXdata) (cdadr (member '(1070 . 76) dXdata)) 0))
(setvar 'dimsd1 (if (member '(1070 . 281) dXdata) (cdadr (member '(1070 . 281) dXdata)) 0))
(setvar 'dimsd2 (if (member '(1070 . 282) dXdata) (cdadr (member '(1070 . 282) dXdata)) 0))
;;;;; matches suppression [if any] of Dimension & Extension lines only; could add more override matches
;;;;; match Obliquing?
;;;;; QDIM option?
(cond ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; doesn't account for relocated text [adds 128 bit to (assoc 70) value]
((= dtyp 163) (command "_.dimdiameter"))
((= dtyp 164) (command "_.dimradius"))
(T ; continue and baseline options available for all but diameter and radius
(initget "New Continue Baseline")
(setq dbase (getkword "Dimension basis [New/Continue/Baseline] <N>: "))
(cond
((= dbase "Continue") (command "_.dimcontinue" "s" obj))
((= dbase "Baseline") (command "_.dimbaseline" "s" obj))
((= dtyp 33) (command "_.dimaligned"))
((or (= dtyp 34) (= dtyp 37)) (command "_.dimangular"))
((or (= dtyp 38) (= dtyp 102)) (command "_.dimordinate")); 38 Ydatum, 102 Xdatum
((= dtyp 32)
(setq drot (cdr (assoc 50 objdata))); dimension line rotation
(if (not (or (= drot 0) (= drot (/ pi 2)))); other than 0 or 90 degrees
(command "_.dimrotated" (* (/ drot pi) 180))
(command "_.dimlinear")
); end if
); end Rotated varieties
); end cond - dimension basis option
); end continuable types
); end cond - variety of dimension
); end Dimension object type
;
((= objtyp "LEADER")
(command "_.dimstyle" "r" (cdr (assoc 3 objdata)))
(setvar 'cecolor "BYLAYER"); leaders don't honor color overrides
(setvar 'celtscale 1.0); leaders don't honor linetype scale [even though they do honor linetypes]
(setq ldrform (if (= (cdr (assoc 72 objdata)) 0) "ST" "S")); STraight vs. Spline format
(setvar 'cmdecho 1)
(command "_.leader" pause pause "f" ldrform)
); end Leader object type
;;;;; QLEADER option?
;
((= objtyp "TEXT")
(setvar 'textstyle (setq tsty (cdr (assoc 7 objdata))))
(setvar 'textsize (setq tht (cdr (assoc 40 objdata))))
(setq
trot (angtos (cdr (assoc 50 objdata))); rotation - current angular units
tins10 (cdr (assoc 10 objdata)); left end of baseline [insertion point if Left justified]
tins11 (cdr (assoc 11 objdata)); insertion point [other than Left justified]
tjust72 (cdr (assoc 72 objdata))
tjust73 (cdr (assoc 73 objdata))
tjust1 (nth tjust73 '(0 "B" "M" "T"))
tjust2 (nth tjust72 '("L" "C" "R" "A" "M" "F"))
tjust (if (= tjust73 0) tjust2 (strcat tjust1 tjust2)); if single-letter justification, 72 only; otherwise, combination of 73+72
tstyht (cdr (assoc 40 (tblsearch "style" tsty))); Style's height, to check for override to fixed-height Style
thtover (and (/= tstyht 0) (/= tstyht tht) (/= tjust "A"))
; T if Style is fixed-height, but selected text has different height override, not from Aligned justification
twd (cdr (assoc 41 objdata)); width factor
tstywd (cdr (assoc 41 (tblsearch "style" tsty))); Style's width factor, to check for override
twdover (and (/= tstywd twd) (/= tjust "F"))
; T if selected text has width override different from Style's width factor, not from Fit justification
); end setq
; [NOTE: height and/or width overrides must be imposed *after* end of command; new Text entities
; will appear at standard height/width during command, and will have overrides imposed afterwards;
; if MM is followed by Text or Dtext for more of the same, such overrides will not be imposed -- must
; use Match Properties, or use MM again instead of Text/Dtext command.]
(if (or thtover twdover); if selected has either non-Aligned-based height override or non-Fit-based width override
(setq lastent (entlast)); put marker at last entity, to gather all subsequent entities later
); end if
(initget "New Continuation")
(setq tcont (getkword "\nNew insertion point or Continuation of selected text [N/C] <N>: "))
(setvar 'cmdecho 1)
(cond; - Text insertion-point New-vs.-Continuation choice
((or (= tcont "New") (not tcont)); when with New user-supplied insertion point [explicit or default]
(cond; non-fixed- vs. fixed-height Style
((= (cdr (assoc 40 (tblsearch "style" tsty))) 0); NON-fixed-height Style
(cond; justification
((= tjust "A") (command "_.dtext" "j" "a" pause pause)); Aligned [no height or rotation]
((= tjust "F") (command "_.dtext" "j" "f" pause pause "")); Fit [no rotation]
((and (= tjust72 0) (= tjust73 0)) (command "_.dtext" pause "" trot)); Plain-left
(T (command "_.dtext" "s" tsty "j" tjust pause "" trot)); other justifications
); end cond - justification sub-category
);end NON-fixed-height Style Text category
(T; FIXED-height Style
(cond; justification
((or (= tjust "A") (= tjust "F")) (command "_.dtext" "j" "a" pause pause)); Aligned or Fit [no rotation]
((and (= tjust72 0) (= tjust73 0)) (command "_.dtext" pause trot)); Plain-left
(T (command "_.dtext" "j" tjust pause trot)); other justifications
); end cond - justification sub-category
);end FIXED-height Style Text category
); end cond - non-fixed vs. fixed determination
); end cond - New user-supplied insertion point option
(T; when Continuation of selected text
(cond; non-fixed- vs. fixed-height Style
((= (cdr (assoc 40 (tblsearch "style" tsty))) 0); NON-fixed-height Style
(cond; justification
((= tjust "A") (command "_.text" "j" "a" tins10 tins11 "" "_.dtext" "")); Aligned [no height or rotation]
((= tjust "F") (command "_.text" "j" "f" tins10 tins11 "" "" "_.dtext" "")); Fit [no rotation]
((and (= tjust72 0) (= tjust73 0)) (command "_.text" tins10 "" trot "" "_.dtext" "")); Plain-left
(T (command "_.text" "j" tjust tins11 "" trot "" "_.dtext" "")); other justifications
); end cond - justification sub-category
);end NON-fixed-height Style Text category
(T; FIXED-height Style
(cond; justification
((or (= tjust "A") (= tjust "F")) (command "_.text" "j" "a" tins10 tins11 "" "_.dtext" "")); Aligned or Fit [no rotation]
((and (= tjust72 0) (= tjust73 0)) (command "_.text" tins10 trot "" "_.dtext" "")); Plain-left
(T (command "_.text" "j" tjust tins11 trot "" "_.dtext" "")); other justifications
); end cond - justification sub-category
);end FIXED-height Style Text category
); end cond - non-fixed vs. fixed determination
); end cond - Continuation of selected Text option
); end cond - Text insertion-point New-vs.-Continuation choice
(if (or thtover twdover); if either or both kind(s) of override
(progn ; make list of new Dtext command's new entities [can be more than one]
(while (> (getvar 'cmdactive) 0)
(command pause)
); end while - wait for completion of dtext command
(setq tnext (entnext lastent) tlist (list tnext)); start list with first of entities
(while (entnext tnext) (setq tnext (entnext tnext) tlist (cons tnext tlist))); put remainder into list
); end progn
); end if
(if thtover
(foreach x tlist
(setq
tdata (entget x)
tdata (subst (cons 40 tht) (assoc 40 tdata) tdata); impose height override
); end setq
(entmod tdata)
(entupd x)
); end foreach
); end if
; [NOTE: if Text of fixed-height Style has height override, must be imposed *after* command;
; if doing sequential lines using Enter between, individual Text entity heights will have height
; override imposed to match selected Text, but line *spacing* will be as for height in Style
; definition, *not* adjusted for imposed override height.]
(if twdover
(foreach x tlist
(setq
tdata (entget x)
tdata (subst (cons 41 twd) (assoc 41 tdata) tdata); impose width override
); end setq
(entmod tdata)
(entupd x)
); end foreach
); end if
); end Text object type
;
((= objtyp "MTEXT")
(setq
tjustno (cdr (assoc 71 objdata)); justification number
tjust; justification text
(nth tjustno '(0 "TL" "TC" "TR" "ML" "MC" "MR" "BL" "BC" "BR"))
trot (angtos (cdr (assoc 50 objdata))); rotation - current angular units
tstyht (cdr (assoc 40 (tblsearch "style" (cdr (assoc 7 objdata))))); Style's height
); end setq
(setvar 'textstyle (cdr (assoc 7 objdata))); must do outside Mtext command, or line spacings revert to defaults
(setvar 'textsize (cdr (assoc 40 objdata)))
(setvar 'tspacetype (cdr (assoc 73 objdata)))
(setvar 'tspacefac (cdr (assoc 44 objdata)))
(setvar 'cmdecho 1)
(initdia)
(if (/= tstyht (cdr (assoc 40 objdata))); Mtext of fixed-height style has different height override
(command "_.mtext" pause "h" (cdr (assoc 40 objdata)) "j" tjust "r" trot); ask for height
(command "_.mtext" pause "j" tjust "r" trot); don't
); end if
); end Mtext object type
;
((= objtyp "RTEXT")
(command
"_.text" "_style" "standard" (getvar 'viewctr) 1 (angtos (cdr (assoc 50 objdata))) "delete"
; Assumes Standard text style has 0 height; rotation is in current angular units.
; Draws temporary piece of text to make selected object's angle current -- apparently
; no System Variable to set, and seems to need to be set prior to Rtext command.
"_.erase" "_last" ""
); end command
(setvar 'textstyle (setq tsty (cdr (assoc 7 objdata))))
(setvar 'textsize (setq tht (cdr (assoc 40 objdata))))
(C:rtext)
); end Rtext object type
;
((= objtyp "ARCALIGNEDTEXT")
(setvar 'textstyle (setq tsty (cdr (assoc 7 objdata))))
(command "_.arctext")
); end Arctext object type
;
((= objtyp "POINT")
(initget 1 "Divide Measure")
(setq pdm (getpoint "\nSpecify a point or [Divide/Measure]: "))
(cond
((= pdm "Divide") (command "_.divide"))
((= pdm "Measure") (command "_.measure"))
(T
(command "_.point" pdm)
(setvar 'cmdecho 1)
(while T (command "_.point" pause))
); end specified-Point condition
); end cond
); end Point object type
;
((= objtyp "3DSOLID"); [couldn't figure a way to distinguish types from entity data]
(initget "Box Wedge CYlinder COne Sphere Torus Extrude Revolve Union Intersect")
(setq 3Dtyp (getkword
"\n3D Solid command [Box/Wedge/CYlinder/COne/Sphere/Torus/Extrude/Revolve/Union/Intersect] <B>: "))
(if (not 3Dtyp); user hit Enter
(command "_.box"); then - use default
(command (strcat "_." 3Dtyp)); else - entered option
); end if
); end 3DSolid object type
;
((= objtyp "ATTDEF") (initdia) (command "_.ATTDEF"))
;
((= objtyp "VIEWPORT") (command "_.vports"))
;
((= objtyp "BODY")
(initget "Acisin Explode")
(command
(strcat
"_."
(getkword "\nAcisIn/Explode 3D solid [A/E]? ")
); end strcat
); end command
); end Body object type
;
((= objtyp "PLANT") (C:lsnew))
;
; other possible up-to-2004 entity types/commands: 3DSIN?
; other newer-than-2004 entity types/commands: 3DDWF? DGNATTACH/DGNIMPORT? DIMJOGGED/DIMJOGLINE?
; DISTANTLIGHT? DWFATTACH? FIELD? HELIX? IMPRESSION? IMPRINT? JOGSECTION? LOFT? MARKUP?
; MESH? MLEADER? PDFATTACH? PLANESURF? POINTLIGHT? POLYSOLID? QVDRAWING? SECTIONPLANE?
; SPOTLIGHT? TABLE? TINSERT? DYNAMIC BLOCK?
;
(T ; none of the above object types
(alert
(strcat
"Routine is not yet set up to Make More of the "
objtyp
" object type,\nbut has set current Properties to match it."
); end strcat
): end alert
); end none-of-the-above condition
;
); end OVERARCHING TEST for each object type
;
(if dohatch; (command) part if referred to from Hatch or Insert old-style Hatch object types above
(progn
(initget "Bhatch Hatch")
(setq htyp (getkword "\nBhatch or Hatch [B/H] <B>: "))
(if (= htyp "Hatch")
(command "_.hatch")
(progn (initdia) (command "_.bhatch"))
); end if - type of hatch command
); end progn
); end if
;
(setvar 'cmdecho cmde)
(princ)
); end defun
(prompt "\nType MM to Make More the same as an existing object.")
; end MakeMore.lsp
Advertisements

About AutoCAD Tips

This blog serves as a knowledge base for myself (and anyone else) so that I can reference tips & tricks that I have learned and also refer others to it as well. I hope that this blog helps you learn at least one tip to make your drafting/design experience better.
This entry was posted in AutoLISP, AutoLISP: Creating, Layers, New in 2011. Bookmark the permalink.

8 Responses to AutoLISP: Make More (like ADDSELECTED)

  1. Ramesh says:

    I want draw some circles(holes) on a line (gauge line) by different distances. I have a lisp code. but not working. please rectify my code or give any lisp for me
    My lisp code :
    (defun c:hh ( / rows cols rowd rowv rowh rowo hole )
    (setq
    cols (getint “\nEnter the number of columns (|||) : “)
    rowd (getdist (strcat “\nGauge Line : “))
    rowo (getdist (strcat “\n1st Hole: “))
    rowh (getdist (strcat “\n2nd Hole / center : “))
    rowb (getdist (strcat “\n3rd Hole / center : “))

    hole (getdist (strcat “\nHole diameter ” (rtos 17.5) “>: “))
    )
    (if (= rows nil)(setq rows 0))
    (if (= cols nil)(setq cols 1))
    (if (= rowd nil)(setq rowd 3))
    (if (= rowh nil)(setq rowh 1))
    (if (= rowb nil)(setq rowb 1))
    (if (= rowo nil)(setq rowo 25))
    (if (= hole nil)(setq hole 17.5))
    (setq ins (getpoint “\nSelect insertion point: “))
    (setq ins (polar ins 0 rowo))
    (repeat cols

    (setq lstpnt (polar ins (* pi 1.5) rowd))
    (entmake (list (cons 0 “circle”)(cons 10 lstpnt)(cons 40 (/ hole 2.0))))

    (repeat (1- rows)
    (setq lstpntt (polar lstpnt (* pi 1.5) rowh))
    (entmake (list (cons 0 “circle”)(cons 10 2ndpnt)(cons 40 (/ hole 2.0))))

    (setq lstpnt (polar 2ndpnt (* pi 1.5) rowb))
    (entmake (list (cons 0 “circle”)(cons 10 3rdpnt)(cons 40 (/ hole 2.0))))
    )
    (setq ins (polar ins 0 rowh))
    )
    (princ)
    )

    • AutoCAD Tips says:

      Hello Ramesh,
      I tried the code that you provided and it doesn’t make much sense to me. Below is a routine that lets you place circles along a line. It does so by placing the circle’s center point at the line’s end point:

      (defun c:divwithcircles (/ objts objt_length strt_pt pts valA)
      (vl-load-com)
      (defun
      Circle (cen rad)
      (entmakex
      (list (cons 0 "CIRCLE") (cons 10 cen) (cons 40 rad))))
      (if (setq objts (car (entsel)))
      (progn
      (setq CDia (getreal "\nCircle Diameter: ")
      CNos (- (getint "\nNumber of Circles: ") 1)
      objts
      (vlax-ename->vla-object objts)
      objt_length
      (vlax-curve-getDistAtParam
      objts
      (vlax-curve-getEndParam objts))
      val
      (/ objt_length CNos))
      (setq valA val)
      (circle (vlax-curve-getStartPoint objts) (/ CDia 2))
      (repeat Cnos
      (circle (vlax-curve-getPointAtDist objts val) (/ CDia 2))
      (setq val (+ val valA)))))
      (princ))

      Below is a routine that does the same as above, but instead, it places the quadrant of the circle at the endpoint of the line. This way, the circle is completely on the line:

      (defun c:divwithcircqua ( / _circle p1 p2 no di an sp i ucsz )
      (defun _circle ( center radius )
      (entmakex (list (cons 0 "CIRCLE") (cons 10 center) (cons 40 radius) (cons 210 ucsz)))
      )
      (setq ucsz (trans '(0. 0. 1.) 1 0 t))
      (if
      (and
      (setq p1 (getpoint "\nSpecify First Point: "))
      (setq p2 (getpoint "\nSpecify Second Point: " p1))
      (progn
      (initget 6)
      (setq no (getint "\nSpecify Number of Circles: "))
      )
      (setq di (getdist "\nSpecify Diameter of Circles: "))
      )
      (progn
      (setq p1 (trans p1 1 ucsz) p2 (trans p2 1 ucsz)
      an (angle p1 p2) di (/ di 2.)
      p1 (polar p1 an di) p2 (polar p2 an (- di))
      )
      (if (= 1 no)
      (setq sp (/ (distance p1 p2) 2.) i 0)
      (setq sp (/ (distance p1 p2) (1- no)) i -1)
      )
      (repeat no (_circle (polar p1 an (* (setq i (1+ i)) sp)) di))
      )
      )
      (princ)
      )

      Below is a link to a routine that acts like the first routine but lets you specify one side of a polyline…
      https://autocadtips.wordpress.com/2011/06/20/autolisp-divide-polyline-segment/

      thanks for stopping by,
      ~Greg

      • Ramesh says:

        Hello Sir
        Thank you very much for response. The code what you sent is nice. but it is not useful to me, circles should not divide the line as equal parts, i should be divide as required parts on selected line. May be i couldn’t explain to you. I am sending the drawing what we are using regularly. Please find the attached PDFs file.

        Thank you.

      • Ramesh says:

        acad2008/ osnap/ From? Temp Track Point?
        I apologies for this new thread, I don’t know if this even qualifies as one. You see I have this little problem that is driving me crazy and I really needs some help on this subject.
        I do not know how to use the From and Temporary Tracking Point that is added to my osnap list along with the end, mid, center…. My help page doesn’t show that it even exists. Can someone help me before I go crazy?

      • Ramesh says:

        Can anybody develop below lisp for I Beam.

        (defun c:ukc ()

        ;define the function

        ;************************************************* *******

        ;Save System Variables

        (setq oldsnap (getvar “osmode”))
        ;save snap settings

        (setq oldblipmode (getvar “blipmode”))
        ;save blipmode setting

        ;************************************************* *******
        ;Switch OFF System Variables

        (setvar “osmode” 0)
        ;Switch OFF snap

        (setvar “blipmode” 0)
        ;Switch OFF Blipmode

        ;************************************************* *******

        ;Get User Inputs

        (initget (+ 1 2 3))
        ;check user input

        (setq wl (getdist “\nLength of Web : “))
        ;get the length of the Length of Web

        (initget (+ 1 2 3))
        ;check user input

        (setq fl (getdist “\nLength of Flange : “))
        ;get the Length of Flange

        (initget (+ 1 2 3))
        ;check user input

        (setq wt (getdist “\nWeb Thickness : “))
        ;get the thickness of the Web

        (initget (+ 1 2 3))
        ;check user input

        (setq ft (getdist “\nFlange Thickness : “))
        ;get the Flange Thickness

        (initget (+ 1 2 3))
        ;check user input

        (setq rr (getdist “\nRoot radius : “))
        ;get the Root radius

        (initget (+ 1 2 3))
        ;check user input

        (setq nd (getdist “\nDepth of Section : “))
        ;get the depth of the Section

        ;End of User Inputs
        ;************************************************* ********
        ;Get Insertion Point

        (setvar “osmode” 32)
        ;switch ON snap

        (while
        ;start of while loop

        (setq ip (getpoint “\nInsertion Point : “))
        ;get the insertion point

        (setvar “osmode” 0)
        ;switch OFF snap

        ;************************************************* *******
        ;Start of Polar Calculations

        (setq p2 (polar ip (dtr 90.0)(/ nd 2)))
        (setq p3 (polar p2 (dtr 180.0)(/ fl 2)))
        (setq p4 (polar p3 (dtr 270.0) ft))
        (setq p5 (polar p4 (dtr 0.0) (-(-(/ fl 2)(/ wt 2)) rr)))
        (setq p56 (polar p5 (dtr 270.0) rr))
        (setq p6 (polar p56 (dtr 0.0) rr))
        (setq p7 (polar p6 (dtr 270.0) wl))
        (setq p78 (polar p7 (dtr 180.0) rr))
        (setq p8 (polar p78 (dtr 270.0) rr))
        (setq p9 (polar p8 (dtr 180) rr))
        (setq p10 (polar p9 (dtr 270) ft))
        (setq p11 (polar p10 (dtr 0.0) fl))
        (setq p12 (polar p11 (dtr 90) ft))
        (setq p13 (polar p12 (dtr 180.0) (-(-(/ fl 2)(/ wt 2)) rr)))
        (setq p1314 (polar p13 (dtr 90) rr))
        (setq p14 (polar p1314 (dtr 180.0) rr))
        (setq p15 (polar p14 (dtr 90.0) wl))
        (setq p1516 (polar p15 (dtr 0.0) rr))
        (setq p16 (polar p1516 (dtr 90.0) rr))
        (setq p17 (polar p16 (dtr 0.0)(-(-(/ fl 2)(/ wt 2)) rr)))
        (setq p18 (polar p17 (dtr 90.0) ft))

        ;End of Polar Calculations

        ;************************************************* *********

        ;Start of Command Function

        (command “Line” p2 p3 p4 p5 “c”
        “Line” p6 p7 “”
        “Line” p8 p9 p10 p11 p12 p13 “”
        “Line” p14 p15 “”
        “Line” p16 p17 p18 p2 “”
        “arc” p56 p6 p5 “”
        “arc” p78 p8 p7 “”
        “arc” p1314 p14 p13 “”
        “arc” p1516 p16 p15 “”

        ) ;End Command
        ;End of Command Function

        ;************************************************* *********

        (setvar “osmode” 32)
        ;Switch ON snap

        );end of while loop

        ;************************************************* *********

        ;Reset System Variable

        (setvar “osmode” oldsnap)
        ;Reset snap

        (setvar “blipmode” oldblipmode)
        ;Reset blipmode

        ;************************************************* *********

        (princ)
        ;finish cleanly

        ) ;end of defun

        ;************************************************* *********

        ;This function converts Degrees to Radians.

        (defun dtr (x)
        ;define degrees to radians function

        (* pi (/ x 180.0))
        ;divide the angle by 180 then
        ;multiply the result by the constant PI

        ) ;end of function

        ;************************************************* *********
        (princ) ;load cleanly
        ;***************************

  2. AutoCAD Tips says:

    Ramesh,
    I think that you might benefit from visiting an actual forum for some of these questions. There are people who are able to answer your questions more quickly than I am and there are a ton of free lisp routines and threads that might already address your questions

    http://www.theswamp.org (my favorite)
    http://www.cadtutor.net (another favorite)
    http://forums.autodesk.com/
    http://www.augi.com

    ~Greg

  3. Mosad Elewa says:

    Great job Kent Cooper, this is Mosad Elewa (the original creater of this lisp routine) i was searching my name when i came across the lisp routine which i made very long time ago which was published by CADALYST and won the lisp routine of the month, i’m glade that you made the necessary modification to it to make it work perfectly, i still use it in my daily drafting and i can’t work without.

    • AutoCAD Tips says:

      Mosad,
      Kent does stop by here from time to time so I think that he will see this post. If not, i will pass it along to him any way…
      Thanks for the time and effort put into making this routine. It’s great when someone takes a tool in AutoCAD and then makes it better on their own as you did with this routine. And then Kent has even stepped it up a notch too.
      Thanks
      ~Greg

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s