Chapter 10 Source code.

;;; Source code from the book "AutoCAD expert's Visual LISP"

;;; (c) 2012 Ediciones ARTUAL, S.L. Barcelona, Espa?a.

;;;Copyright © 2012-2020 by Reinaldo N. Togores. All rights reserved.
;;; Use of this code is allowed mentioning the book and its author.

;;;Chapter 10. Drawing with Visual LISP.

(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.0t)
  (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