;;; (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 12. Modifying entities.
(defun cmd-change-color (selection color-index)
(vl-cmdf "._chprop" selection "" "_C" color-index ""))
;;;Listing 12.1. Changing color with CHPROP.
(defun endpoint-circle (radius / lines i line-ent pin pfi)
(if (setq lines (ssget "X" '((0 . "LINE"))))
(progn (setq i 0)
(while (setq line-ent (ssname lines i))
(setq pin (code-value 10 line-ent)
pfi (code-value 11 line-ent))
(if (not (member pin drawn))
(progn (vl-cmdf "._circle" pin radius)
(setq drawn (cons pin drawn))))
(if (not (member pfi drawn))
(progn (vl-cmdf "._circle" pfi radius)
(setq drawn (cons pfi drawn))))
(setq i (1+ i))))))
;;;Listing 12.2. Function that draws circles at the line endpoints.
(defun trim-line-circle (/ circles lines obj endpoints)
(if (and (setq circles (ssget "X" '((0 . "CIRCLE"))))
(setq lines (ssget "X" '((0 . "LINE")))))
(progn (setq i 0)
(while (setq obj (ssname lines i))
(setq endpoints (cons
(code-value 11 obj)
(cons (code-value 10 obj) endpoints))
i (1+ i)))
(foreach pt endpoints
(vl-cmdf "._trim" circles "" pt ""))
(if (> (getvar "cmdactive") 0)
(vl-cmdf)))))
;;;Listing 12.3. Function that demonstrates the use of TRIM from a VLISP function.
(defun number-nodes (pt-lst height / i pt)
(setq
pt-lst
(vl-sort
pt-lst
'(lambda (pt1 pt2) (> (cadr pt1) (cadr pt2)))))
(setq i 0)
(while (setq pt (nth i pt-lst))
(ent-text (itoa (1+ i))
(getvar "textstyle")
pt
pt
height
1
2)
(setq i (1+ i))))
;;;Listing 12.4. Graph nodes numbering function.
(defun C:GRAPH (/ *error* radius drawn)
(defun *error* (msg)
(command-s "._UNDO" "_End")
(command-s "._U")
(cmd-out)
(prompt msg))
(cmd-in)
(vl-cmdf "._UNDO" "_Begin")
(setq radius (default-value
'getreal
"\nSpecify cirle radius "
10.0))
(endpoint-circle radius)
(trim-line-circle)
(number-nodes drawn radius)
(vl-cmdf "._UNDO" "_End")
(cmd-out)
(princ))
;;;Listing 12.5. New command that automates the creation of network diagrams.
(defun ent-mod-layer (ent-lst lyr)
(entmod (subst (cons 8 lyr) (assoc 8 ent-lst) ent-lst)))
;;;Listing 12.6. Function that changes an entity's Layer.
(defun ent-move-obj (ent-lst)
(if (apply 'or
(mapcar '(lambda (x) (= x (cdr (assoc 0 ent-lst))))
'("CIRCLE" "ELLIPSE" "ARC" "INSERT" "POINT"
"SHAPE" "TEXT" "MTEXT")))
(while (setq ctr (getpoint "\nMove to point: "))
(entmod (subst (cons 10 ctr) (assoc 10 ent-lst) ent-lst)))
(prompt "\nObject not admitted"))
(princ))
;;;Listing 12.7. Function that moves objects using ENTMOD.
(defun ent-to-layout (ename layout copy / le)
(setq le (entget ename))
(setq le (subst (cons 410 layout) (assoc 410 le) le))
(cond ((= (strcase layout) "MODEL")
(if (assoc 67 le)
(setq le (subst (cons 67 0) (assoc 67 le) le))))
(t
(if (assoc 67 le)
(setq le (subst (cons 67 1) (assoc 67 le) le))
(setq le (cons (cons 67 1) le)))))
(if copy
(entmake le)
(entmod le)))
;;;Listing 12.8. Function that changes or copies between Layouts.
(defun 3d? (entity-name)
(and (= (code-value 0 entity-name) "POLYLINE")
(not (zerop (logand (code-value 70 entity-name))))))
;;;Listing 12.9. Predicate that identifies a 3D polyline.
(defun close-pline (entity-name / lst)
(if (wcmatch (code-value 0 entity-name) "*POLYLINE")
(progn
(setq lst (entget entity-name))
(entmod
(subst
(cons 70 (logior (code-value 70 entity-name) 1))
(assoc 70 lst)
lst)))))
;;;Listing 12.10. Function that closes any kind of polyline.
(defun open-pline (entity-name / lst)
(if (wcmatch (code-value 0 entity-name) "*POLYLINE")
(progn
(setq lst (entget entity-name))
(entmod
(subst
(cons 70 (logand (code-value 70 entity-name) (+ 0 8 16 64)))
(assoc 70 lst)
lst)))))
;;;Listing 12.11. Function to open polylines using LOGAND.
(defun open-close-pline (entity-name closed / lst)
(if (wcmatch (code-value 0 entity-name) "*POLYLINE")
(progn
(setq lst (entget entity-name))
(entmod
(subst (cons 70
(boole (if closed
7
1)
(code-value 70 entity-name)
(if closed
1
(~ 1))))
(assoc 70 lst)
lst)))))
;;;Listing 12.12. Function to close or open polylines using BOOLE.
(defun prop-lwpol-vertices (lwpol / i x y z lst)
(setq z (getpropertyvalue lwpol "Elevation")
i 0)
(while
(not (vl-catch-all-error-p
(setq x (vl-catch-all-apply
'getpropertyvalue
(list lwpol "Vertices" i "Position/X")))))
(setq y (getpropertyvalue
lwpol
"Vertices"
i
"Position/Y")
lst (cons (list x y z) lst)
i (1+ i)))
(reverse lst))
;;;Listing 12.13. Reading a LWPolyline's vertices using getpropertyvalue.
(defun prop-spline-pts (spl / i n lst)
(setq i 0)
(cond ((not (vl-catch-all-error-p
(setq n (vl-catch-all-apply
'getpropertyvalue
(list spl "NumFitPoints")))))
(repeat n
(setq lst (cons (getpropertyvalue
spl
"FitPoints"
i
"Position")
lst)
i (1+ i))))
(t
(setq n (getpropertyvalue spl "NumControlPoints"))
(repeat n
(setq lst (cons (getpropertyvalue
spl
"ControlPoints"
i
"Position")
lst)
i (1+ i)))))
(reverse lst))
;;;Listing 12.14. Reading a Spline's Fit or Control points using getpropertyvalue.
(defun noncom-props (ent / props value)
(setq
props (vl-remove-if
'null
(mapcar
'(lambda (prop)
(setq value (vl-catch-all-apply
'getpropertyvalue
(list ent prop)))
(if (not (vl-catch-all-error-p value))
(cons prop value)))
'("LocalizedName" "3dPolylineClosed" "Angle" "Area"
"Associative" "BasePoint" "Center"
"Circumference" "Closed" "Color" "ConstantWidth"
"Degree" "Delta" "Diameter" "DrawOrder"
"EcsRotation" "Elevation" "EndAngle"
"EndFitTangent" "EndParam" "EndPoint"
"FitTolerance" "GradientAngle" "GradientCentered"
"GradientColor1" "GradientColor2" "GradientName"
"GradientOneColorMode" "GradientShift"
"GradientType" "HasFitData" "HasBulges"
"HasWidth" "HatchObjectType" "HatchStyle"
"IsHatch" "IsOnlyLines" "ISOPenWidth"
"IsOriginDisableForSVH" "IsPeriodic" "IsPlanar"
"IsSolidFill" "KnotParameterization" "Length"
"MajorAxis" "MajorRadius" "MinorAxis"
"MinorRadius" "Normal" "NumberOfHatchLines"
"NumberOfLoops" "NumberOfPatternDefinitions"
"NumControlPoints" "NumFitPoints" "Origin"
"Pattern" "PatternAngle" "PatternDouble"
"PatternFillType" "PatternName" "PatternScale"
"PatternSpace" "PatternType" "Plinegen"
"Poly3dType" "Position" "Radius" "RadiusRatio"
"SecondPoint" "ShadeTintValue" "SplineFrame"
"SplineIsPeriodic" "StartAngle" "StartFitTangent"
"StartParam" "StartPoint" "Thickness"
"TotalAngle" "Type" "UnitDir"))))
(cond ((= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
(setq
props (cons (cons "Vertices" (prop-lwpol-verts ent))
(reverse props))))
((= (cdr (assoc 0 (entget ent))) "SPLINE")
(setq props
(cons (cons (if (vl-catch-all-error-p
(vl-catch-all-apply
'getpropertyvalue
(list ent "NumFitPoints")))
"ControlPoints"
"FitPoints")
(prop-spline-pts ent))
(reverse props)))))
(reverse props))
;;;Listing 12.15. Reading the useful properties for 2D GRAPHIC OBJECTS.
(defun RGB->TrueColor (rgb)
(apply '+
(mapcar '(lambda (c i) (lsh c i))
rgb
'(16 8 0))))
;;;Listing 12.16. Function that converts RGB values to TrueColor.
(defun TrueColor->RGB (tcol)
(mapcar '(lambda (i) (lsh (lsh tcol i) -24))
'(8 16 24)))
;;;Listing 12.17. Function to extract RGB values from a TrueColor.
(defun ent-chgcolor (entity newcolor / entlist)
(setq entlist (entget entity))
(setq entlist
(cond
((and (assoc 430 newcolor) (assoc 430 entlist))
(subst (assoc 430 newcolor) (assoc 430 entlist)
entlist))
((and (not (assoc 430 newcolor)) (assoc 430 entlist))
(vl-remove (assoc 430 entlist) entlist))
((assoc 430 newcolor)
(reverse (cons (assoc 430 newcolor) (reverse entlist))))
(t entlist)))
(setq entlist
(cond
((and (assoc 420 newcolor) (assoc 420 entlist))
(subst (assoc 420 newcolor) (assoc 420 entlist) entlist))
((and (not (assoc 420 newcolor)) (assoc 420 entlist))
(vl-remove (assoc 420 entlist) entlist))
((assoc 420 newcolor)
(reverse (cons (assoc 420 newcolor) (reverse entlist))))
(t entlist)))
(setq entlist
(if (assoc 62 entlist)
(subst (assoc 62 newcolor) (assoc 62 entlist) entlist)
(reverse (cons (assoc 62 newcolor) (reverse entlist)))))
(entmod entlist))
;;;Listing 12.18. Function that changes an entity's color using entmod.
(defun C:ENTCOL (/)
(ent-chgcolor
(car (entsel "\nSelect entity to change color:"))
(acad_truecolordlg
(cons 420 (RGB->TrueColor (list 255 255 255)))
t)))
;;;Listing 12.19. Test program for ent-chgcolor.
(defun rgb->string (rgb /)
(vl-string-translate
" "
","
(vl-string-trim "()" (vl-princ-to-string rgb))))
;;;Listing 12.20. Converting the RGB color list to string.
(defun prop-chgcolor (entity newcolor /)
(cond
((assoc 430 newcolor)
(setpropertyvalue
entity
"Color"
(vl-string-translate "$" "," (cdr (assoc 430 newcolor)))))
((assoc 420 newcolor)
(setpropertyvalue
entity
"Color"
(rgb->string
(TrueColor->RGB (cdr (assoc 420 newcolor))))))
(t
(setpropertyvalue
entity
"Color"
(itoa (cdr (assoc 62 newcolor)))))))
;;;Listing 12.21. Function that changes an entity's color using setpropertyvalue.
(defun color-scale
(rgb-ini rgb-fin number / inc-rgb color-list n)
(setq inc-rgb (mapcar '(lambda (i)
(/ (- (nth i rgb-ini) (nth i rgb-fin))
number))
(list 0 1 2))
n 0)
(repeat (1- number)
(setq color-list (cons
(mapcar
'-
rgb-ini
(mapcar '(lambda (i) (* i n)) inc-rgb))
color-list)
n (1+ n)))
(reverse (cons rgb-fin color-list)))
;;;Listing 12.22. Function that calculates the RGB values for a color scale.
(defun scale-data (/ ini fin steps ops sel)
(prompt "\nColor scale data.")
(while (or (not ini) (not fin) (not steps))
(setq ops ""
ops (if (not ini)(strcat ops "Initial ") ops)
ops (if (not fin)(strcat ops "Final ") ops)
ops (if (not steps)(strcat ops "Steps ") ops))
(if (not (setq msg (replace "/" " " ops)))(setq msg ops))
(apply 'initget (list 1 ops))
(setq sel (getkword (strcat "\nSelect option [" msg "]: ")))
(cond
((= sel "Initial")
(while (not (setq ini
(assoc 420 (acad_truecolordlg '(420 . 16391690) nil))))
(alert "Please select \nin the Truecolor tab.")))
((= sel "Final")
(while (not (setq fin
(assoc 420 (acad_truecolordlg '(420 . 410356) nil))))
(alert "Please select \nin the Truecolor tab.")))
((= sel "Steps")
(initget (+ 1 2 4))
(setq steps
(getint "\nNumber of colors in the scale: ")))))
(list
(TrueColor->RGB (cdr ini))(TrueColor->RGB (cdr fin)) steps))
;;;Listing 12.23. Color scales data entry.
(defun sel-hatch (/ hatch-list hatch-sel)
(setq hatch-sel (ssget "X" '((0 . "HATCH")))
i 0)
(while (setq ent (ssname hatch-sel i))
(setq hatch-list (cons ent hatch-list)
i (1+ i)))
hatch-list)
;;;Listing 12.24. Function for retrieving the HATCH objects.
(defun set-color (hatch-list colors / ent area areas hatches i
d-area indices index)
(setq i 0)
(while (setq ent (nth i hatch-list))
(setq area (vl-catch-all-apply
'getpropertyvalue
(list ent "Area")))
(if (not (vl-catch-all-error-p area))
(setq areas (cons area areas)
hatches (cons ent hatches)))
(setq i (1+ i)))
(setq d-area
(/ (- (apply 'max areas) (apply 'min areas))
(length colors)))
(setq indices
(mapcar '(lambda (a) (read (rtos (/ a d-area) 2 0))) areas)
i 0)
(while (setq ent (nth i hatches))
(setq index (nth i indices))
(cond ((< index 0) (setq index 0))
((>= index (length colors))
(setq index (1- (length colors)))))
(setpropertyvalue
ent
"Color"
(rgb->string (nth index colors)))
(setq i (1+ i))))
;;;Listing 12.25. Function that applies the colors.
(defun C:COLOR-AREA (/ data scale colors hatches)
(if (setq hatches (sel-hatch))
(progn (setq data (scale-data))
(setq scale (apply 'color-scale data))
(set-color hatches scale))
(prompt "\nNo hatch entities found"))
(princ))
;;;Listing 12.26. Main function that applies TrueColor to HATCH objects.
(defun ax-link (obj name url description location /
links link)
(vl-load-com)
(setq links (vla-get-Hyperlinks obj)
link (vla-Add links name))
(vla-put-URL link url)
(vla-put-URLDescription link description)
(vla-put-URLNamedLocation link location))
;;;Listing 12.27. Function that adds a hyperlink to an entity.
(defun ax-rectangular-array (ename num-row num-col num-level
dist-row dist-col dist-level)
(vla-ArrayRectangular
(vlax-ename->vla-object ename)
num-row
num-col
num-level
dist-row
dist-col
dist-level))
;;;Listing 12.28. Creating a rectangular array with ActiveX.
No comments:
Post a Comment