Command:ADS
This function adds new object alike selected one. The routine checks polyline width and multiline justification. Works also with AECB objects (Autocad Vertical versions objects)Code:
;;; =================================================
;;; ADDSELECTED_AECB_v3_00.LSP
;;;
;;; Written by Andrzej Kalinowski, www.autolisps.blogspot.com
;;; v1.00 - 15.05.2016
;;; v2.01 - 01.03.2019 - updated polyline width restoration and error section
;;; v2.02 - 20.05.2020 - fixed bug with polyline width
;;; v3.00 - 22.12.2021 - corrected matching properties for Labelcuves in Autocad MEP
;;; v3.01 - 27.04.2024 - added option to create rectangle after selectiong an another rectanle (or polyliene)
;;;
;;; Command: ADS - adds new object alike selected one. The routine checks polyline width and multiline justification.
;;; Works also with AECB objects (Autocad MEP / Autocad Architecture ).
;;; =================================================
(vl-load-com)
(defun c:ADS (/ obj1 type1 justi1 MLSca1 MLSty1 lay1 col1 Ltyp1 Lw1 obj2 entlist2 pt1 plwid01 rec1)
;-----------------------------------------
;error section
;-----------------------------------------
(defun *error* (msg) (princ "error: ") (princ msg) (princ) );
(defun errtrap1 (errormsg1 / )
(ADS_RESTORE_VAR)
(if (and errormsg1 (not (wcmatch (strcase errormsg1) "*BREAK*,*CANCEL*,*QUIT*") ) )
(prompt (strcat "\n--------------------------------------------\nError: " errormsg1) );then
);if
(princ)
);defun err
;-----------------------------------------
(setq
temperr *error* ;saving error
*error* errtrap1 ; assigning errtrap1 function to *error* variable
old_plinewid (getvar "PLINEWID")
old_clayer (getvar "CLAYER")
old_celtype (getvar "CELTYPE");linetype
old_celweight (getvar "CELWEIGHT"); lineweight
old_cecolor (getvar "CECOLOR")
);setq
;-----------------------------------------
;object selection
;-----------------------------------------
(setq obj1 nil)
(prompt "select object")
(while (= obj1 nil)
(setq obj1 (ssget "_:S+.") )
(if (= obj1 nil)
(princ "\nwrong object");then
(if (> (sslength obj1) 1);else-checks if there is only one object selected
(progn
(princ "\nselect only one object") (princ)
(setq obj1 nil)
);progn
);end if
);end if
);end while
(setq obj1 (ssname obj1 0) );takes first and only one element from selection set. You can retreive entlist from element of seleset - not from selection set.
(setq type1 (cdr (assoc 0 (entget obj1) )) )
(setvar "CLAYER" (cdr (assoc 8 (entget obj1) )))
(if (assoc 6 (entget obj1) ) (setvar "CELTYPE" (cdr (assoc 6 (entget obj1) ))) ); Linetype
(if (assoc 370 (entget obj1) ) (setvar "CELWEIGHT" (cdr (assoc 370 (entget obj1) ))) ); Linetype
(ADS_SETCECOLOR (entget obj1))
(setq type1 (cdr (assoc 0 (entget obj1) )) )
(if
(and
(member type1 (list "LWPOLYLINE" "POLYLINE"))
(member (vla-get-objectname (vlax-ename->vla-object obj1 ) ) (list "AcDbPolyline" "AcDb2dPolyline"))
(/= (cdr (assoc 43 (entget obj1) )) nil)
);and
(setvar "PLINEWID" (cdr (assoc 43 (entget obj1) )) )
);if
;-----------------------------------------
(cond
;HVAC
( (= type1 "AECB_DUCTFLEX") (command "_DuctFlexAddSelected" obj1) )
( (= type1 "AECB_PIPEFITTING") (command "_pipeFittingAddSelected" obj1) )
( (= type1 "AECB_MVPART") (command "_MvPartAddSelected" obj1) )
( (= type1 "AECB_PIPE") (command "_PipeAddSelected" obj1) )
( (= type1 "AECB_DUCT") (command "_DuctAddSelected" obj1) )
( (= type1 "AECB_DUCTFITTING") (command "_DuctFittingAddSelected" obj1) )
( (= type1 "AECB_PIPECUSTOMFITTING") (command "_AecbPipeCustomFitting" obj1) )
( (= type1 "AECB_DUCTCUSTOMFITTING") (command "_AecbDuctCustomFitting" obj1) )
( (= type1 "AEC_MVBLOCK_REF") (command "_TagAddSelected" obj1) )
;ARCHITECTURAL AND STRUCTURAL
( (= type1 "AEC_COLUMN_GRID") (command "_COLUMNGRIDADD" obj1) )
( (= type1 "AEC_CEILING_GRID") (command "_CEILINGGRIDADD" obj1) )
( (= type1 "AEC_ROOFSLAB") (command "_RoofSlabAddSelected" obj1) )
( (= type1 "AEC_ROOF") (command "_RoofAdd" obj1) )
( (= type1 "AEC_SLAB") (command "_SlabAddSelected" obj1) )
( (= type1 "AEC_WALL") (command "_WallAddSelected" obj1) )
( (= type1 "AEC_DOOR") (command "_DoorAddSelected" obj1) )
( (= type1 "AEC_OPENING") (command "_OpeningAddSelected" obj1) )
( (= type1 "AEC_WINDOW_ASSEMBLY") (command "_DoorWinAssemblyAddSelected" obj1) )
( (= type1 "AEC_WINDOW") (command "_WindowAddSelected" obj1) )
( (= type1 "AEC_STAIR") (command "_StairAddSelected" obj1) )
( (= type1 "AEC_RAILING") (command "_RailingAddSelected" obj1) )
( (= type1 "AEC_SPACE") (command "_SpaceAddSelected" obj1) )
( (= type1 "AEC_ZONE") (command "_ZoneAddSelected" obj1) )
( (= type1 "AEC_MASS_ELEM") (command "_MassElementAddSelected" obj1) )
( (= type1 "AEC_CURTAIN_WALL_LAYOUT") (command "_CurtainWallAddSelected" obj1) )
( (= type1 "AEC_CURTAIN_WALL_UNIT") (command "_AecCwUnitAdd" obj1) )
( (= type1 "AECS_MEMBER") (command "_MemberAddSelected" obj1) )
;ELECTRICAL
( (= type1 "AECB_DEVICE") (command "_DeviceAddSelected" obj1) )
( (= type1 "AECB_CONDUITFITTING") (command "_ConduitFittingAddSelected" obj1) )
( (= type1 "AECB_CABLETRAY") (command "_CableTrayAddSelected" obj1) )
( (= type1 "AECB_CONDUIT") (command "_ConduitAddSelected" obj1) )
( (= type1 "AECB_CABLETRAYFITTING") (command "_ConduitFittingAddSelected" obj1) )
( (= type1 "AECB_PANEL") (command "_PanelAddSelected" obj1) )
( (= type1 "AECB_WIRE") (command "_WireAddSelected" obj1) )
;SCHEMATIC
( (= type1 "AECB_SCHEMATIC") (command "_SLineAddSelected" obj1) )
( (= type1 "AECB_SCHEMATICSYMBOL") (command "_SymbolAddSelected" obj1) )
( (= type1 "AECB_SCHEMATIC_PIPE") (command "_PlumbingLineAddSelected" obj1) )
( (= type1 "AECB_SCHEMATICPIPEFITTING") (command "_PlumbingFittingAddSelected" obj1) )
;OTHER
( (= type1 "AECB_LABEL_CURVE") (command "_LabelCurveAddSelected" obj1) )
;( (= type1 "ABST_DB_HANGER") () ) ;There is no add selected function for that object type
( (= type1 "MLINE")
(setq MLSca1 (vlax-get (vlax-ename->vla-object obj1 ) 'MLineScale)
MLSty1 (vlax-get (vlax-ename->vla-object obj1 ) 'StyleName)
);setq
(cond
( (= 0 (vlax-get (vlax-ename->vla-object obj1 ) 'Justification) ) (setq justi1 "_Top") )
( (= 1 (vlax-get (vlax-ename->vla-object obj1 ) 'Justification) ) (setq justi1 "_Zero") )
( (= 2 (vlax-get (vlax-ename->vla-object obj1 ) 'Justification) ) (setq justi1 "_Bottom") )
);cond
(command "_ADDSELECTED" obj1 "_J" justi1 "_S" MLSca1 "_ST" MLSty1 )
)
( (member (vla-get-objectname (vlax-ename->vla-object obj1 ) ) (list "AcDbPolyline" "AcDb2dPolyline"))
(if (= (type (vl-catch-all-apply 'vlax-get-property (list (vlax-ename->vla-object obj1 ) 'ConstantWidth ) ) ) 'REAL) ; checking if polyline hast a global width. for AcDb2dPolyline group code 43. doesnt exist. ( Group code 43 defined global polyline widht for AcDbPolyline)
(setq plwid01 (vlax-get (vlax-ename->vla-object obj1 ) 'ConstantWidth) ) ; nil or value
);if
(initget "Rectangle")
(setq pt1 (getpoint "\nSpecify first point, or [Rectangle]: ") )
(if (= pt1 "Rectangle")
(progn
(setq rec1 1)
(if (/= plwid01 nil)
(command "_Rectang" "_Width" plwid01 pause pause)
(command "_Rectang" pause pause)
);if
);progn
(command "_ADDSELECTED" obj1 pt1)
);if
)
(t (command "_ADDSELECTED" obj1) )
);cond
(while (= 1 (getvar "cmdactive") );prevents exiting whole routine after finishing drawing the polyline
(command pause)
);while
;-----------------------------------------
;matching layer, color and linetype
;-----------------------------------------
(if rec1
(progn
(setq obj2 (vlax-ename->vla-object (entlast)))
(vla-put-linetype obj2 (vla-get-linetype (vlax-ename->vla-object obj1) ))
(vla-put-lineweight obj2 (vla-get-lineweight (vlax-ename->vla-object obj1) ))
(vla-put-linetypescale obj2 (vla-get-linetypescale (vlax-ename->vla-object obj1) ))
);progn
);if
;|
(setq obj2 (vlax-ename->vla-object (entlast)))
(setq entlist2 (entget (entlast)))
(cond
( (/= (assoc 430 (entget obj1)) nil)
(vla-put-truecolor obj2 (vla-get-truecolor (vlax-ename->vla-object obj1) ))
(setq entlist2 (append entlist2 (list (assoc 430 (entget obj1)))));setq
(entmod entlist2)
)
( (and (/= (assoc 420 (entget obj1)) nil) (= (assoc 430 (entget obj1)) nil) )
(vla-put-truecolor obj2 (vla-get-truecolor (vlax-ename->vla-object obj1) ))
)
( T (vla-put-color obj2 (vla-get-color (vlax-ename->vla-object obj1) )) )
);cond
(vla-put-linetype obj2 (vla-get-linetype (vlax-ename->vla-object obj1) ))
(vla-put-lineweight obj2 (vla-get-lineweight (vlax-ename->vla-object obj1) ))
(vla-put-layer obj2 old_lay1)
|;
;-----------------------------------------
;restoring to old system variables
;-----------------------------------------
(ADS_RESTORE_VAR)
(princ);exiting quietly
);defun
;;; ================================================
;;; ADS_RESTORE_VAR
;;; ================================================
(defun ADS_RESTORE_VAR ( / )
(setvar "PLINEWID" old_plinewid)
(setvar "CLAYER" old_clayer)
(setvar "CELTYPE" old_celtype);linetype
(setvar "CELWEIGHT" old_celweight);lineweight
(setvar "CECOLOR" old_cecolor)
(setq *error* temperr)
(setq old_plinewid nil old_clayer nil old_celtype nil old_celweight nil old_cecolor nil temperr nil)
);defun
;;; ================================================
;;; ADS_SETCECOLOR
;;; ================================================
(defun ADS_SETCECOLOR (engt1 / rgbval1);feed with objects entity list (entget)
(cond
( (assoc 430 engt1 ) (setvar "CECOLOR" (cdr(assoc 430 engt1 ) )) )
( (assoc 420 engt1 )
(setq rgbval1 (cdr(assoc 420 engt1 ) ))
(setvar "CECOLOR"
(strcat
"RGB:"
(itoa (lsh (lsh rgbval1 8) -24) ) "," ;R
(itoa (lsh (lsh rgbval1 16) -24) ) ",";G
(itoa (lsh (lsh rgbval1 24) -24) );B
);strcat
);setvar
)
( (assoc 62 engt1 ) (setvar "CECOLOR" (itoa (cdr (assoc 62 engt1 ) ) ) ) )
( (= nil (assoc 62 engt1 )) (setvar "CECOLOR" "256" ) );ByLayer
);cond
);defun
Version history:
1.00 - [15.05.2016] First release.
[...] - misc. updates
2.01 - 01.03.2019 - updated polyline width restoration and error section
2.02 - 20.05.2020 - fixed bug with polyline width
3.00 - 22.12.2021 - corrected matching properties for Labelcuves in Autocad MEP
3.01 - 27.04.2024 - added option to create rectangle after selectiong an another rectanle (or polyliene)
Compatibility:
2011 and later versions of Autocad and its vertical versions
Download file:
ADDSELECTED_AECB_v3_01.FAS
No comments:
Post a Comment