(defun cmd-circle (center radius /)
(cmd-in)
(command "._circle" center radius)
(cmd-out))
;;;Listing 10.1. Drawing a circle using COMMAND.
(defun cmdf-circle (/ pt)
(cmd-in)
(vl-cmdf "._circle"
(setq pt (getpoint "\nPick center:"))
(getdist pt "\nSpecify radius: "))
(cmd-out))
;;;Listing 10.2. Drawing a circle using VL-CMDF.
(defun cmd-ttr (pt1 pt2 radius /)
(setvar "cmdecho" 0)
(vl-cmdf "._circle" "_ttr" pt1 pt2 radius)
(setvar "cmdecho" 1))
;;;Listing 10.3. Drawing a circle from two tangency points and radius.
(defun cmd-circle (center radius /)
(if (> (getvar "CMDACTIVE") 0)
(vl-cmdf))
(cmd-in)
(vl-cmdf "._circle" center radius)
(cmd-out)
(if (> (getvar "CMDACTIVE") 0)
(progn (vl-cmdf) nil)
t))
;;;Listing 10.4. CMD-CIRCLE function cancelling running commands.
(defun cmd (cmd-name /)
(if (> (getvar "CMDACTIVE") 0)
(vl-cmdf))
(apply 'vl-cmdf (list cmd-name))
(while (> (getvar "CMDACTIVE") 0) (vl-cmdf pause)))
;;;Listing 10.5. Universal function to execute commands interactively.
(defun cmd-test ()
(alert "Press OK to select a color")
(initdia)
(cmd "._COLOR")
(alert "Press OK to draw a circle")
(cmd "._CIRCLE"))
;;;Listing 10.6. Function that launches commands from an AutoLISP program.
(defun cmd-poly (point-list 2d closed /)
(if (> (getvar "CMDACTIVE") 0)
(vl-cmdf))
(cmd-in)
(vl-cmdf
(if 2d
"._pline"
"._3dpoly"))
(foreach pt point-list (vl-cmdf pt))
(vl-cmdf
(if closed
"_cl"
""))
(cmd-out)
(if (> (getvar "CMDACTIVE") 0)
(progn (vl-cmdf) nil)
t))
;;;Listing 10.7. Function to draw a 2D or 3D polyline.
(defun ent-pt (xyz)
(entmake (list '(0 . "POINT") (cons 10 xyz))))
;;;Listing 10.8. Function for drawing a point.
(defun code-value (key ename)
(cdr (assoc key (entget ename))))
;;;Listing 10.9. Retrieving the value associated with a DXF group code.
(defun ent-copy (ent-lst / ctr)
(if
(apply 'or
(mapcar '(lambda (x) (= x (cdr (assoc 0 ent-lst))))
'("CIRCLE" "ELLIPSE" "ARC" "INSERT" "POINT" "SHAPE" "TEXT" "MTEXT")))
(while (setq ctr (getpoint "\nNew location: "))
(entmake
(subst (cons 10 ctr) (assoc 10 ent-lst) ent-lst)))
(prompt "\nObject not admitted"))
(princ))
;;;Listing 10.10. Function using ENTMAKE to copy objects.
(defun ent-circ (center radius lyr normal-vec)
(entmake
(list '(0 . "CIRCLE")
'(100 . "AcDbEntity")
'(100 . "AcDbCircle")
(cons 8 lyr)
(cons 10 center)
(cons 40 radius)
(cons 210 normal-vec))))
;;;Listing 10.11. Function drawing circles in different Layers and planes.
(defun ent-text (txt-string style pt1 pt2 txt-height h-just v-just)
(entmake
(list '(0 . "TEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 1 txt-string)
(cons 7 style)
(cons 10 pt1)
(cons 11 pt2)
(cons 40 txt-height)
(cons 72 h-just)
(cons 73 v-just))))
;;;Listing 10.12. Fuction that creates a single line text entity.
(defun ent-draw-text (pt-ins height numbering)
(ent-text
numbering
(getvar "TEXTSTYLE")
pt-ins
pt-ins
height
1
2))
;;;Listing 10.13. Replacement for draw-text function using entmake.
(defun just-txt-ops (token /)
(list
(cond
((or (wcmatch (strcase just) "@L") (wcmatch token "L*"))
(cons 72 0))
((or (wcmatch (strcase just) "@C") (wcmatch token "C*"))
(cons 72 1))
((or (wcmatch (strcase just) "@R") (wcmatch token "R*"))
(cons 72 2))
((wcmatch (strcase token) "A*") (cons 72 3))
((wcmatch (strcase token) "M*") (cons 72 4))
((wcmatch (strcase token) "F*") (cons 72 5)))
(cond
((wcmatch (strcase token) "T@") (cons 73 3))
((wcmatch (strcase token) "M@") (cons 73 2))
((wcmatch (strcase token) "B@") (cons 73 1))
(t (cons 73 0)))))
;;;Listing 10.14. Mapping group code values to justification option tokens.
(defun ent-just-txt (txt-string style pt1 pt2 txt-height just ang /)
(entmake
(append
(list '(0 . "TEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 1 txt-string)
(cons 7 style)
(cons 10 pt1)
(cons 11 pt2)
(cons 40 txt-height)
(cons 50 ang))
(just-txt-ops just))))
;;;Listing 10.15. Function that creates text justified using option tokens.
(defun C:ENT-TXT (/ just pt1 pt2 height txt-string)
(prompt "\Justify text: ")
(initget
1
"Left Align Fit Center Middle Right TL TC TR ML MC MR BL BC BR")
(setq just (getkword
"[Left/Align/Fit/Center/Middle/Right/TL/TC/TR/ML/MC/MR/BL/BC/BR]:"))
(cond
((or (= just "Align") (= just "Fit"))
(initget 1)
(setq pt1 (getpoint
"\nFirst endpoint of text baseline: "))
(initget 1)
(setq pt2 (getpoint
pt1
"\nSecond endpoint of text baseline: ")))
(t
(initget 1)
(setq pt1 (getpoint
"\nSpecify text insertion point: ")
pt2 pt1)))
(initget 1)
(setq height (getdist
pt1
"Text height: "))
(initget 1)
(setq txt-string (getstring
"\nEnter text: "))
(ent-just-txt
txt-string
(getvar "TEXTSTYLE")
pt1
pt2
height
just
0)
(princ))
;;;Listing 10.16. Sample program using ent-just-txt.
(defun values (key lst / sublist result)
(while (setq sublist (assoc key lst))
(setq result (cons (cdr sublist) result)
lst (cdr (member sublist lst))))
(reverse result))
;;;Listing 10.17 Extraction of multiple values from an association list.
(defun vert-poly (lst / coord-z)
(setq coord-z (cdr (assoc 38 lst)))
(mapcar '(lambda (2d) (reverse (cons coord-z (reverse 2d))))
(values 10 lst)))
;;;Listing 10.18. Function returning a LWPOLYLINE's vertices.
(defun ent-poly (vertices closed)
(entmake
(append
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 38
(if (> (length (car vertices)) 2)
(nth 2 (car vertices))
(getvar "elevation")))
(cons 90 (length vertices))
(cons 70
(if closed
1
0)))
(mapcar '(lambda (x) (cons 10 x)) vertices))))
;;;Listing 10.19. Polylines creation using ENTMAKE.
(defun ent-poly-2 (vertices closed lyr normal-vec)
(entmake
(append
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 8 lyr)
(cons 38
(if (> (length (car vertices)) 2)
(nth 2 (car vertices))
(getvar "elevation")))
(cons 90 (length vertices))
(cons 70
(if closed
1
0))
(cons 210 normal-vec))
(mapcar '(lambda (x) (cons 10 x)) vertices))))
;;;Listing 10.20. Polyline creation specifying layer and coordinate system.
(defun ent-header (lyr closed)
(entmake
(list '(0 . "POLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDb3dPolyline")
(cons 8 lyr)
'(10 0.0 0.0 0.0)
(cons 70
(+ 8
(if closed
1
0))))))
;;;Listing 10.21. Function that creates the 3D polyline header.
(defun ent-vertex (xyz lyr)
(entmake
(list '(0 . "VERTEX")
'(100 . "AcDbEntity")
'(100 . "AcDbVertex")
'(100 . "AcDb3dPolylineVertex")
(cons 8 lyr)
(cons 10 xyz)
'(70 . 32)
'(50 . 0))))
;;;Listing 10.22. Function that creates a VERTEX entity.
(defun ent-seqend (lyr)
(entmake
(list '(0 . "SEQEND") '(100 . "AcDbEntity") (cons 8 lyr))))
;;;Listing 10.23. Function that creates the SEQEND entity.
(defun ent-3dpol (vertices lyr closed)
(ent-header lyr closed)
(foreach xyz vertices (ent-vertex xyz lyr))
(ent-seqend lyr))
;;;Listing 10.24. Function that creates a 3D polyline using entmake.
(defun enames-block (id-ent / tmp)
(while id-ent
(setq tmp (cons (cdr (assoc -1 (entget id-ent))) tmp)
id-ent (entnext id-ent)))
(reverse tmp))
;;;Listing 10.25. Obtaining the components of a block.
(defun ent-attdef (tag msg value pt-ins height visible)
(entmake
(list '(0 . "ATTDEF")
'(8 . "0")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 pt-ins)
(cons 40 height)
(cons 1 value)
'(100 . "AcDbAttributeDefinition")
(cons 3 msg)
(cons 2 tag)
(cons 70
(if visible
0
1)))))
;;;Listing 10.26. ATTDEF entity created by ENTMAKE.
(defun ent-block (name pt-ins attrib-var)
(entmake
(list '(0 . "BLOCK")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockBegin")
'(8 . "0")
(cons 2 name)
(cons 10 pt-ins)
(cons 70
(if attrib-var
2
0)))))
;;;Listing 10.27. Creation of the block header.
(defun ent-endblk ()
(entmake
(list '(0 . "ENDBLK")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockEnd")
'(8 . "0"))))
;;;Listing 10.28. Creation of the Block's end-of sequence entity.
(defun ent-tower-block ()
(ent-block "TOWER" '(0.0 0.0 0.0) t)
(ent-poly-2
'((-0.5 -0.5 0.0)
(0.5 -0.5 0.0)
(0.5 0.5 0.0)
(-0.5 0.5 0.0))
t
"0"
'(0.0 0.0 1.0))
(ent-poly-2
'((-0.5 -0.5 0.0) (0.5 0.5 0.0))
nil
"0"
'(0.0 0.0 1.0))
(ent-poly-2
'((0.5 -0.5 0.0) (-0.5 0.5 0.0))
nil
"0"
'(0.0 0.0 1.0))
(ent-attdef
"ID-TOWER"
"Tower number"
"00"
'(0.75 -0.5 0.0)
0.5
nil)
(ent-endblk))
;;;Listing 10.29 Function for the creation of a block.
(defun ed-tower-block ()
(vl-cmdf "_BEDIT" "TOWER")
(ent-poly-2
'((-0.5 -0.5 0.0)
(0.5 -0.5 0.0)
(0.5 0.5 0.0)
(-0.5 0.5 0.0))
t
"0"
'(0.0 0.0 1.0))
(ent-poly-2
'((-0.5 -0.5 0.0) (0.5 0.5 0.0))
nil
"0"
'(0.0 0.0 1.0))
(ent-poly-2
'((0.5 -0.5 0.0) (-0.5 0.5 0.0))
nil
"0"
'(0.0 0.0 1.0))
(ent-attdef
"ID-TOWER"
"Tower number"
"00"
'(0.75 -0.5 0.0)
0.5
nil)
(vl-cmdf "_BCLOSE" "_Save"))
;;;Listing 10.30. TOWER block creation using the Block Editor.
(defun current-space (drawing /)
(vla-get-block (vla-get-ActiveLayout drawing)))
;;;Listing 10.31. Function that retrieves the current space.
(defun 3d->2d (pt) (list (car pt) (cadr pt)))
;;;Listing 10.32. 3d->2d auxiliary function.
(defun ax-poly (vertices closed / obj)
(setq obj (vla-AddLightWeightPolyline
(current-space *aevl:drawing*)
(vlax-make-variant
(ax-list->array
(apply 'append (mapcar '3d->2d vertices))))))
(if closed
(vlax-put-property obj 'Closed :vlax-true))
(if (nth 2 (car vertices))
(vlax-put-property obj 'Elevation (nth 2 (car vertices))))
obj)
;;;Listing 10.33. Creating a LWPOLYLINE using ActiveX.
(defun ax-3dpol (vertices closed / obj)
(setq obj (vla-add3dpoly
(current-space *aevl:drawing*)
(vlax-make-variant
(ax-list->array (apply 'append vertices)))))
(if closed
(vlax-put-property obj 'closed :vlax-true))
obj)
;;;Listing 10.34. 3D polyline with ActiveX methods.
(defun ax-block-coll (/)
(if (null *aevl:blocks*)
(progn (setq *aevl:blocks* (vla-get-blocks *aevl:drawing*))
(pragma '((protect-assign *aevl:blocks*)))
*aevl:blocks*)
*aevl:blocks*))
;;;Listing 10.35. Referencing the BLOCKS collection.
(defun ax-survey-pt (/ tmp attrib)
(setq tmp (vla-add (ax-block-coll)
(vlax-3d-point '(0.0 0.0 0.0))
"SURVEY-PT"))
(vla-addline
tmp
(vlax-3d-point '(-0.5 0.0 0.0))
(vlax-3d-point '(0.5 0.0 0.0)))
(vla-addline
tmp
(vlax-3d-point '(0.0 -0.5 0.0))
(vlax-3d-point '(0.0 0.5 0.0)))
(setq attrib (vla-addattribute
tmp
0.5
0
"Point elevation"
(vlax-3d-point '(0.0 -1.0 0.0))
"ELEV"
"0.0"))
(vlax-put-property attrib "Alignment" acAlignmentTopCenter)
(vlax-put-property
attrib
"TextAlignmentPoint"
(vlax-3d-point '(0.0 -1.0 0.0)))
tmp)
;;;Listing 10.36. Creating a block using ActiveX methods.
(defun cmd-layer (name color ltype)
(vl-cmdf "._layer" "_m" name "_c" color name "_l" ltype name ""))
;;;Listing 10.37. Function that creates a layer using the LAYER comand.
(defun cmd-loadltype (name)
(if (not (tblsearch "LTYPE" name))
(vl-cmdf "._linetype"
"_l"
name
(if (= (getvar "measurement") 1)
(findfile "acadiso.lin")
(findfile "acad.lin"))
"")))
;;;Listing 10.38. Loading a Line Type.
(defun locale-ltyp (name / lang ltyps)
(setq lang (vl-position
(getvar "UILocale")
'("en-US" "de-DE" "es-ES" "fr-FR" "it-IT" "pt-BR"))
ltyps '(("BORDER" "RAND" "MORSE_G" "BORDURE" "BORDO" "BORDA")
("BORDER2" "RAND2" "MORSE_G2" "BORDURE2" "BORDO2" "BORDA2")
("BORDERX2" "RANDX2" "MORSE_Gx2" "BORDUREX2" "BORDOX2" "BORDAX2")
("CENTER" "MITTE" "CENTRO" "AXES" "CENTRO" "CENTRO")
("CENTER2" "MITTE2" "CENTRO2" "AXES2" "CENTRO2" "CENTRO2")
("CENTERX2" "MITTEX2" "CENTROx2" "AXESX2" "CENTROX2" "CENTROX2")
("DASHDOT" "STRICHPUNKT" "TRAZO_Y_PUNTO" "TIRETPT" "TRATTOPUNTO"
"TRAÇOPONTO")
("DASHDOT2" "STRICHPUNKT2" "TRAZO_Y_PUNTO2" "TIRETPT2" "TRATTOPUNTO2"
"TRAÇOPONTO2")
("DASHDOTX2" "STRICHPUNKTX2" "TRAZO_Y_PUNTOX2" "TIRETPTX2"
"TRATTOPUNTOX2" "TRAÇOPONTOX2")
("DASHED" "STRICHLINIE" "TRAZOS" "INTERROMPU" "TRATTEGGIATA"
"TRACEJADA")
("DASHED2" "STRICHLINIE2" "TRAZOS2" "INTERROMPU2" "TRATTEGGIATA2"
"TRACEJADA2")
("DASHEDX2" "STRICHLINIEX2" "TRAZOSX2" "INTERROMPUX2"
"TRATTEGGIATAX2" "TRACEJADAX2")
("DIVIDE" "GETRENNT" "MORSE_D" "DIVISE" "DIVIDI" "DIVISA")
("DIVIDE2" "GETRENNT2" "MORSE_D2" "DIVISE2" "DIVIDI2" "DIVISA2")
("DIVIDEX2" "GETRENNTX2" "MORSE_DX2" "DIVISEX2" "DIVIDIX2" "DIVISAX2")
("DOT" "PUNKT" "PUNTOS" "POINTILLE" "PUNTO" "PONTO")
("DOT2" "PUNKT2" "PUNTOS2" "POINTILLE2" "PUNTO2" "PONTO2")
("DOTX2" "PUNKTX2" "PUNTOSX2" "POINTILLEX2" "PUNTOX2" "PONTOX2")
("HIDDEN" "VERDECKT" "LÍNEAS_OCULTAS" "CACHE" "NASCOSTA" "OCULTA")
("HIDDEN2" "VERDECKT2" "LÍNEAS_OCULTAS2" "CACHE2" "NASCOSTA2"
"OCULTA2")
("HIDDENX2" "VERDECKTX2" "LÍNEAS_OCULTASX2" "CACHEX2" "NASCOSTAX2"
"OCULTAX2")
("PHANTOM" "PHANTOM" "VALS" "FANTOME" "FANTASMA" "FANTASMA")
("PHANTOM2" "PHANTOM2" "VALS2" "FANTOME2" "FANTASMA2" "FANTASMA2")
("PHANTOMX2" "PHANTOMX2" "VALSX2" "FANTOMEX2" "FANTASMAX2"
"FANTASMAX2")
("FENCELINE1" "GRENZE1" "LÍMITE1" "LIMITE1" "LIMITE1" "CERCA1")
("FENCELINE2" "GRENZE2" "LÍMITE2" "LIMITE2" "LIMITE2" "CERCA2")
("TRACKS" "EISENBAHN" "VÍAS" "RAILS" "BINARIO" "TRILHAS")
("BATTING" "ISOLATION" "AISLAMIENTO" "ISOLATION" "ISOLAMENTO"
"ISOLAMENTO")
("HOT_WATER_SUPPLY" "HEISSWASSERLEITUNG" "AGUA_CALIENTE" "EAU_CHAUDE"
"ALIMENTAZIONE_ACQUA_CALDA" "LINHA_DE_ÁGUA_QUENTE")
("GAS_LINE" "GASLEITUNG" "GAS" "GAZ" "GASDOTTO" "LINHA_DE_GÁS")
("ZIGZAG" "ZICKZACK" "ZIGZAG" "ZIGZAG" "ZIGZAG" "ZIGUEZAGUE")))
(cond
((setq ltyp (assoc (strcase name) ltyps)) (nth lang ltyp))
(t name)))
;;;Listing 10.39. Localized Linetype name translation function.
(defun can-use? (lyr)
(zerop
(logand (cdr (assoc 70 (tblsearch "LAYER" lyr))) (+ 1 4))))
;;;Listing 10.40. Checking if a layer is not off, frozen or locked.
(defun ent-layer (name color ltype)
(entmake
(list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
(cons 2 name)
'(70 . 0)
(cons 62 color)
(cons 6 ltype)
'(290 . 1)
'(370 . -3))))
;;;Listing 10.41. Creating a layer using entmake.
(defun ent-linetype (name description param-list)
(entmake
(append
(list '(0 . "LTYPE")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLinetypeTableRecord")
(cons 2 name)
'(70 . 0)
(cons 3 description)
(cons 72 (ascii (nth 0 param-list)))
(cons 73 (- (length param-list) 1))
(cons 40 (apply '+ (mapcar 'abs (cdr param-list)))))
(apply 'append
(mapcar '(lambda (x) (list (cons 49 x) '(74 . 0)))
(cdr param-list))))))
;;;Listing 10.42. Function that creates a new Linetype in the drawing.
(defun ax-layer (layer-coll name color ltype / lyr)
(setq lyr (vla-add layer-coll name))
(vla-put-Color lyr color)
(vla-put-Linetype lyr ltype)
lyr)
;;;Listing 10.43. Creating a Layer with ActiveX.
(defun ax-loadltype (name / tmp)
(setq name (local-ltyp name))
(if
(not
(ax-exists?
name
(setq tmp (vla-get-Linetypes *aevl:drawing*))))
(progn
(vla-load tmp
name
(if (= (getvar "measurement") 1)
(findfile "acadiso.lin")
(findfile "acad.lin")))
(vla-put-ActiveLinetype *aevl:drawing* (vla-item tmp name)))
(vla-put-ActiveLinetype *aevl:drawing* (vla-item tmp name))))
;;;Listing 10.44. Loading a Linetype using ActiveX.
(defun ax-define-load-ltype (name description definition / file file-id)
(setq file (vl-filename-mktemp nil nil ".lin")
file-id (open file "w"))
(write-line (strcat "*" name "," description) file-id)
(write-line definition file-id)
(close file-id)
(vla-load (vla-get-linetypes *aevl:drawing*) name file)
(vl-file-delete file))
;;;Listing 10.45. Defining and loading a Linetype with ActiveX.
No comments:
Post a Comment