Calculate horizontal & slope distance, bearing, delta X, Y & Z, percent slope between two selected points and Northing & Easting for picked points.


;;; ------------------------------------------------------------------------
;;; DistanceInquiry.lsp v2.1
;;;
;;; Copyright© 04.16.09
;;; Alan J. Thompson (alanjt)
;;;
;;; Contact: alanjt @ TheSwamp.org, CADTutor.net
;;;
;;; Permission to use, copy, modify, and distribute this software
;;; for any purpose and without fee is hereby granted, provided
;;; that the above copyright notice appears in all copies and
;;; that both that copyright notice and the limited warranty and
;;; restricted rights notice below appear in all supporting
;;; documentation.
;;;
;;; The following program(s) are provided "as is" and with all faults.
;;; Alan J. Thompson DOES NOT warrant that the operation of the program(s)
;;; will be uninterrupted and/or error free.
;;;
;;; Calculate horizontal & slope distance, bearing, delta X, Y & Z,
;;; percent slope between two selected points and Northing & Easting
;;; for picked points.
;;;
;;; The following objects may be selected for X,Y,Z:
;;; Arc, Block, Civil 3D Point, Civil 3D Surface, Circle, Ellipse,
;;; Land Desktop Point, AutoCAD Point
;;; * * If C3D surface is selected, user has option to pick point * *
;;; * * within surface and the true elevation is extracted. * *
;;;
;;; Points and bearing are translated to World UCS.
;;;
;;; * * * May be executed transparently * * *
;;;
;;; Revision History:
;;;
;;; v1.1 (04.23.09) 1. Added display of Delta X, Delta Z elevations, slope
;;; distance and Northing & Easting for picked points.
;;; 2. Added subroutines: AT:Arrow and AT:Midpoint
;;; 3. If slope between points is found, direction of
;;; flow is shown.
;;;
;;; v1.2 (04.28.09) 1. Added display of points' elevations, if applicable.
;;; 2. Updated 'AT:Arrow' subroutine.
;;; 3. Added check for elevation calculations to see if
;;; elevations for points are different.
;;;
;;; v1.3 (05.04.09) 1. Added subroutine 'AT:PointSameXY' and check to see
;;; if points are not at the same location, before
;;; calculating any slope information.
;;;
;;; v1.4 (05.12.09) 1. Added display of inquiry information with popup
;;; window, using DosLib. If user has DosLib loaded,
;;; information will display here aswell (must uncomment).
;;;
;;; v1.5 (09.23.09) 1. Added display of inches for flat distance portion. *OMITTED v1.8a*
;;;
;;; v1.6 (09.24.09) 1. Fixed issue with trying to set 'osnapz' on older versions.
;;;
;;; v1.7 (09.24.09) 1. Added display of azimuth.
;;;
;;; v1.8a(11.04.09) 1. Fixed (hopefully) coding to account for user units and luprec setttings.
;;; Added subroutine _RToS to properly set Lunits and Luprec values.
;;; 2. Added subroutine AT:DrawX and will display red "X" at first picked point.
;;; 3. Updated *error* routine.
;;; 4. Removed v1.5 update (stupid idea).
;;; 5. Added subroutines _GetPoint and AT:Entsel, now user has option to select
;;; an object in addition to picking a point.
;;; Accepted objects: C3D points, Point, Circle, Block
;;;
;;; v1.8b(11.17.09) 1. Added display of bearing in radians.
;;;
;;; v1.8c(11.18.09) 1. Added option to select arcs (will use point at radius).
;;;
;;; v1.9 (02.16.10) 1. Added Gradian display for angle between picked points.
;;;
;;; v2.0 (04.04.10) 1. Updated AT:DrawX subroutine.
;;; 2. Added option to select an Ellipse (in addition to other objects).
;;; Will use center point.
;;; 3. Fixed bug with running transparently.
;;;
;;; v2.1 (05.24.10) 1. Added option to select Civil 3D surface and extract elevation.
;;; 2. Replaced subroutine AT:Entsel with _sel. Now connecting line
;;; is drawn from first point to cursor (when in select mode).
;;; 3. When in select mode for second point, distance is dynamically
;;; displayed at the status line.
;;; 4. Fixed bug with "X" at first point not being displayed when
;;; in non-WCS.
;;; 5. Added option to select Land Desktop points.
;;;
;;; ------------------------------------------------------------------------

(defun c:D (/) (c:DistanceInquiry))
(defun c:DistanceInquiry (/ *error* AT:FlatDist AT:Arrow AT:Midpoint AT:PointSameXY AT:DrawX
_GetPoint #PromptString #AddString #OldOsnapz #Luprec #Lunits #Measure
#Arch _RToS #Point1 #Point2 #Bear #Rad #Angle #Grad #Dist #Elev #Slope
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SUBROUTINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; error handler
(defun *error* (#Message)
(and #OldOsnapz (setvar "osnapz" #OldOsnapz))
(grtext)
(and #Message
(not (wcmatch (strcase #Message) "*BREAK*,*CANCEL*,*QUIT*"))
(princ (strcat "\nError: " #Message))
) ;_ and
) ;_ defun

;;; Distance between 2 (no Z value) points
;;; Alan J. Thompson, 3.18.09
(defun AT:FlatDist (#Point1 #Point2)
(distance (list (car #Point1) (cadr #Point1))
(list (car #Point2) (cadr #Point2))
) ;_ distance
) ;_ defun

;;; Display directional arrow
;;; #Location - arrow placement point
;;; #Angle - arrow directional angle
;;; Alan J. Thompson, 04.28.09
(defun AT:Arrow (#Location #Angle / #Size #Point1 #Point2 #Point3)
(setq #Size (* (getvar "viewsize") 0.02)
#Point1 (polar #Location #Angle #Size)
#Point2 (polar #Location (+ #Angle (* pi 0.85)) #Size)
#Point3 (polar #Location (+ #Angle (* pi 1.15)) #Size)
) ;_ setq
(grvecs
(list 4 #Point1 #Point2 #Point2 #Point3 #Point3 #Point1)
) ;_ grvecs
) ;_ defun

;;; Midpoint between two points
;;; Alan J. Thompson, 04.23.09
(defun AT:Midpoint (#Point1 #Point2)
(mapcar '(lambda (x y)
(/ (+ x y) 2.0)
) ;_ lambda
#Point1
#Point2
) ;_ mapcar
) ;_ defun

;;;Check if two points are same X & Y (Z ignored)
;;;Return: T if same, nil if different
;;;Alan J. Thompson, 05.04.09
(defun AT:PointSameXY (#Point1 #Point2)
(equal (list (car #Point1) (cadr #Point1))
(list (car #Point2) (cadr #Point2))
0.00001
) ;_ equal
) ;_ defun

;;; Draw and "X" vector at specified point
;;; P - Placement point for "X"
;;; C - Color of "X" (must be integer b/w 1 & 255)
;;; Alan J. Thompson, 10.31.09
(defun AT:DrawX (P C / d n)
(if (and (vl-consp P)
(setq d (* (getvar "VIEWSIZE") 0.02))
) ;_ and
(progn (grvecs (cons C
(mapcar
(function (lambda (#) (polar P (* # pi) d)))
'(0.25 1.25 0.75 1.75)
) ;_ mapcar
) ;_ cons
) ;_ grvecs
P
) ;_ progn
) ;_ if
) ;_ defun

(defun _sel (pnt msg flt / gr e)
(while (and (setq gr (grread T 15 2))
(/= (car gr) 25)
(not (vl-position (cadr gr) '(13 158)))
(not e)
)
(redraw)
(and pnt (grtext -1 (rtos (distance pnt (cadr gr)))) (grdraw (AT:DrawX pnt 1) (cadr gr) 3 -1))
(princ (strcat "\r" msg))
(if (and (eq 3 (car gr))
(setq e (ssget (cadr gr)))
(wcmatch (cdr (assoc 0 (entget (setq e (ssname e 0))))) flt)
)
(setq e (vlax-ename->vla-object e))
(setq e nil)
)
)
(redraw)
(grtext)
e
)

(defun _GetPoint (#Point #Msg / _Get _ToList #Pnt #NoTrans #Obj #Value #N #E #Z sur pnt elev)
(setq _Get
(lambda (o p / c)
(if
(not (vl-catch-all-error-p (setq c (vl-catch-all-apply 'vlax-get-property (list o p))))
) ;_ not
c
) ;_ if
) ;_ lambda
) ;_ setq
(setq _ToList (lambda (v)
(if v
(vlax-safearray->list (vlax-variant-value v))
) ;_ if
) ;_ lambda
) ;_ setq
(initget 0 "Select sUrface")
(and
(if #Point
(setq #Pnt (getpoint #Point #Msg))
(setq #Pnt (getpoint #Msg))
) ;_ if
(cond
;; selected point
((vl-consp #Pnt)
(setq #Value #Pnt
#NoTrans T
) ;_ setq
)
;; sUrface
((eq "sUrface" #Pnt)
(if
(and
(setq *DI:Surface*
(cond (
;;; (AT:Entsel nil
;;; (strcat "\nSelect Civil 3D surface"
;;; (if *DI:Surface*
;;; " : "
;;; ": "
;;; )
;;; )
;;; '("V" (0 . "AECC_TIN_SURFACE"))
;;; nil
;;; )
(_sel #Point
(strcat "Select Civil 3D surface"
(if *DI:Surface*
(strcat " : "
)
": "
)
)
"AECC_TIN_SURFACE"
)

)
(*DI:Surface*)
)
)
(while (not elev)
(and
(setq pnt (if #Point
(getpoint #Point "\nSpecify point within C3D surface: ")
(getpoint "\nSpecify point within C3D surface: ")
)
)
(setq pnt (trans pnt 1 0))
(or
(> (setq elev (vlax-invoke *DI:Surface* 'FindElevationAtXY (car pnt) (cadr pnt)))
-99999.9
)
(setq elev (prompt "\nPoint outside of surface!"))
)
)
)
)
(setq #Value (list (car pnt) (cadr pnt) elev))
)
)
;; "Select" chosen
((eq "Select" #Pnt)
;;; (princ "\nAcceptable objects: ARC AECC_COGO_POINT CIRCLE ELLIPSE INSERT POINT")
(and
(setq #Obj
(_sel #Point
"Select object: "
"AECC_COGO_POINT,AECC_POINT,ARC,CIRCLE,ELLIPSE,INSERT,POINT"
)
)

;;; (setq
;;; #Obj (AT:Entsel nil
;;; nil
;;; '("V" (0 . "AECC_COGO_POINT,ARC,CIRCLE,ELLIPSE,INSERT,POINT"))
;;; nil
;;; ) ;_ AT:Entsel
;;; ) ;_ setq
(cond
;; aecc_cogo_point (civil 3d)
((eq "AeccDbCogoPoint" (_Get #Obj 'ObjectName))
(and (setq #E (_Get #Obj 'Easting))
(setq #N (_Get #Obj 'Northing))
(setq #Z (_Get #Obj 'Elevation))
(setq #Value (list #E #N #Z))
) ;_ and
)
;;AECC_POINT (land desktop)
((eq "AeccDbPoint" (_Get #Obj 'ObjectName))
(setq #Value (cdr (assoc 11 (entget (vlax-vla-object->ename #Obj)))))
)
;; circle
((vl-position (_Get #Obj 'ObjectName) '("AcDbArc" "AcDbCircle" "AcDbEllipse"))
(setq #Value (_ToList (_Get #Obj 'Center)))
)
;; insert
((eq "AcDbBlockReference" (_Get #Obj 'ObjectName))
(setq #Value (_ToList (_Get #Obj 'InsertionPoint)))
)
;; point
((eq "AcDbPoint" (_Get #Obj 'ObjectName))
(setq #Value (_ToList (_Get #Obj 'Coordinates)))
)
(T (setq #Value nil))
) ;_ cond
) ;_ and
)
) ;_ cond
) ;_ and
(cond
((and #Value #NoTrans) #Value)
((and #Value (not #NoTrans)) (trans #Value 0 1))
(T #Value)
) ;_ cond
) ;_ defun

;; custom rtos
(setq _RToS (lambda (x) (rtos x #Lunits #Luprec)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(vl-load-com)

;; remove any existing arrows & set prompt string
(cond ((eq 1 (getvar 'cmdactive)) (setq #AddString "\n"))
(t (setq #AddString "") (vl-cmdf))
) ;_ cond
(redraw)
(setq #PromptString "\n-------------------------------------------------------")

;; fix osnapz to take actual elevation of points
(and (setq #OldOsnapz (getvar "osnapz")) (setvar "osnapz" 0))

;; retrieve LUPREC, LUNITS & MEASUREMENT settings
(setq #Luprec (getvar "luprec")
#Lunits (getvar "lunits")
#Measure (getvar "measurement")
) ;_ setq

;; account for architectural units (multiply by 12)
(if (and (eq 4 #Lunits) (zerop #Measure))
(setq #Arch 12)
(setq #Arch 1)
) ;_ if

(cond
((and (AT:DrawX (setq #Point1 (_GetPoint nil "\nSpecify first point [Select/sUrface]: ")) 1)
(setq #Point2 (_GetPoint #Point1 "\nSpecify next point [Select/sUrface]: "))
) ;_ and
;; clear "X"
(redraw)
;; points picked, calculation time
(setq #Point1 (trans #Point1 1 0)
#Point2 (trans #Point2 1 0)
#Rad (angle #Point1 #Point2)
#Bear (angtos #Rad 4 4)
#Angle (angtos #Rad 1 4)
#Grad (angtos #Rad 2)
#Dist (* #Arch (AT:FlatDist #Point1 #Point2))
) ;_ setq
;; calc & display Delta X, Y, Z
(setq #PromptString
(strcat #PromptString
"\nDelta X: "
(_RToS (- (car #Point2) (car #Point1)))
", Delta Y: "
(_RToS (- (cadr #Point2) (cadr #Point1)))
", Delta Z: "
(_RToS (- (caddr #Point2) (caddr #Point1)))
) ;_ strcat
) ;_ setq
;; display northing & easting for picked points
(setq #PromptString
(strcat #PromptString
"\nFrom: N="
(_RToS (cadr #Point1))
", E="
(_RToS (car #Point1))
" -> To: N="
(_RToS (cadr #Point2))
", E="
(_RToS (car #Point2))
) ;_ strcat
) ;_ setq
;; if points have elevation, % slope & slope distance calced, direction & point elevations displayed
(cond
((and (or (> (caddr #Point1) 0.)
(> (caddr #Point2) 0.)
) ;_ or
(not (AT:PointSameXY #Point1 #Point2))
(not (eq (caddr #Point1) (caddr #Point2)))
) ;_ and
(setq #Elev (- (caddr #Point2)
(caddr #Point1)
) ;_ -
#Slope (* 100. (/ #Elev #Dist))
) ;_ setq
(setq #PromptString
(strcat #PromptString
"\nSlope Distance: "
(_RToS (* #Arch (distance #Point1 #Point2)))
", Slope: "
(_RToS #Slope)
"% [From: "
(_RToS (caddr #Point1))
" -> To: "
(_RToS (caddr #Point2))
"]"
) ;_ strcat
) ;_ setq
;; draw directional arrow at midpoint between picked points
(AT:Arrow (trans (AT:Midpoint #Point1 #Point2) 0 1)
(if (> (caddr #Point1) (caddr #Point2))
(angle (trans #Point1 0 1) (trans #Point2 0 1))
(angle (trans #Point2 0 1) (trans #Point1 0 1))
) ;_ if
) ;_ AT:Arrow
)
) ;_ cond
;; bearing & distance b/w points
(setq #PromptString
(strcat #PromptString
"\nRad: "
(_RTos #Rad)
", Azm: "
#Angle
", Grad: "
#Grad
", Bear: "
#Bear
", Dist: "
(_RToS #Dist)
(if (and (< #Dist 6.1) (eq (strcase (getvar 'loginname)) "ATHOMPSON"))
(strcat " [" (_RToS (* #Dist 12.)) "in]")
""
) ;_ if
#AddString
) ;_ strcat
) ;_ setq
;; print everything to commandline & user dos_lib if applicable
(prompt #PromptString)

;;(and dos_traywnd (dos_traywnd "Distance Inquiry" #PromptString 360 100 "" 1500))

)
) ;_ cond
;; reset everything
(*error* nil)
(princ)
) ;_ defun

Advertisements

Draw a “buffer” boundary outline of User-specified width around User- selected offsettable object (solved case with wide offsetted polyline: setting width to 0) (added background “paper color hatch” for buffer area)

;;;;; Slightly modified by Igal Averbuh 2018 (solved case with wide offsetted polyline: setting width to 0) (added background "paper color hatch" for buffer area)

;|
BUFFER.lsp [command name: BUFFER]
To put a "buffer" boundary outline of User-specified width around User-
selected Offsettable object(s).
Offsets selected object(s) by specified distance, on both sides of open-ended
objects, or for closed objects, User choice of both sides or outboard only [e.g.
wetlands perimeter would not need inboard buffer edge]. Outboard-only
would be equivalent to regular Offset, except BUFFER determines which
way is outboard without need for User designation, always rounds convex
corners of resulting Polylines, and remembers buffer width.
If object is open-ended [other than Xline], Offsets to both sides & wraps Arc(s)
around end(s) [for Ray, only one end], connecting ends of offset elements to
complete boundary. If object is a Line, Arc or non-Fit/Splined Polyline, joins
buffer boundary into one enclosing Polyline.
Option for resulting buffer boundary to be on same Layer as Source object
or on Current Layer.
Buffer width & Layer choices independent of regular Offset's distance/Layer
options, and are remembered and offered as default on subsequent use.
Under Both-ways option for closed objects, if Circle radius or closed Ellipse
minor radius is not greater than buffer width, goes outboard only.
If Arc or partial Ellipse radius is not greater than buffer width, does not go
inboard, but still wraps arcs around ends and if appropriate, trims to close.
Can fail or have unexpected results if Polyline/Spline has certain conditions,
e.g. self-intersection, or [relative to buffer width] too-tight curvature or too-
close interior approach or too-short end segment(s), or if Ellipse has minor
radius too close to buffer width, because Offsetting can either fail or result
in more than one object.
Kent Cooper, last edited 5 January 2017
|;
;;;;; [doesn't yet work for open objects in different UCS, though for many
;;;;; objects it will look as though it did from current point of view]

;; Set linetype of selected polyline to continuous

(defun c:lts ( / *error* idx sel wid )

(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(princ (strcat "\nError: " msg))
)
(princ)
)

(LM:startundo (LM:acdoc))

(setq sel (ssget "L" (list '(0 . "LWPOLYLINE"))))

(command "_.change" sel "" "_P" "_LT" "continuous" "" "")
)

;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo - Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)

;; End Undo - Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)

;; Active Document - Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
(vl-load-com) (princ)

;; Polyline Width - Lee Mac
;; Applies a given constant width to all segments in a selection of polylines.

(defun c:pw ( / *error* idx sel wid )

(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(princ (strcat "\nError: " msg))
)
(princ)
)

(LM:startundo (LM:acdoc))
(if
;(setq sel (LM:ssget "\nSelect polylines: " '("_:L" ((0 . "LWPOLYLINE,POLYLINE")))))

(setq sel (ssget "L" (list '(0 . "LWPOLYLINE"))))

(progn
(initget 4)
(setq wid 0.0)
;(setq wid (getdist "\nEnter New Width: "))
(repeat (setq idx (sslength sel))
(vla-put-constantwidth (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) wid)
)
)
)
(*error* nil)
(princ)
)

;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo - Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)

;; End Undo - Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)

;; Active Document - Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
(vl-load-com) (princ)

(defun c:chl ()
(command "-hatch" "p" "s" "")
(command "-hatch" "s" "l" "" "p" "s" "co" "t" "255,255,255" "" )
(command "draworder" "l" "" "b")
)

(defun C:BUF
(/ *error* doc svnames svvals ss n ent edata closed new obj etype ang pton e1 e2)

(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); if
(mapcar 'setvar svnames svvals); reset System Variables
(vla-endundomark doc)
(princ)
); defun - *error*

(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(setq ; System Variable saving/resetting without separate variables for each:
svnames '(osmode cmdecho peditaccept offsetgaptype blipmode offsetdist)
svvals (mapcar 'getvar svnames)
); setq
(mapcar 'setvar svnames '(1 1 0)); throughout-routine SV's

(initget (if *bufferdist 0 1)); no Enter on first use
(setq
*bufferdist ; global variable
(cond
( (getdist ; returns nil on Enter
(strcat
"\nBuffer width"
(if *bufferdist (strcat " ") ""); prior-value default if present
": "
); strcat
); getdist
); User-input condition
(*bufferdist); prior value [if present] on Enter
); cond & *bufferdist
); setq
(initget "Current Source")
(setq *bufferlay ; global variable
(cond
( (getkword
(strcat
"\nLayer for buffer outlines [Current/Source] : "
); strcat
); getkword
); User-input condition
(*bufferlay); prior value if present on Enter
("Current"); initial-use default on Enter with no prior value **
; ** if "Source" preferred as initial default, EDIT in two places above
); cond
); setq

(prompt "\nTo add surrounding buffer outline(s),")
(if
(and
(setq ss (ssget "_:L" '((0 . "*LINE,ARC,CIRCLE,ELLIPSE,RAY"))))
; *LINE allows Line/Polyline [any kind]/Spline/Xline/Mline, but Mlines & 3D
; Polylines/Splines can't be offset, and don't want Polygon/Polyface Meshes, so:
(repeat (setq n (sslength ss))
(setq edata (entget (setq ent (ssname ss (setq n (1- n))))))
(if
(or
(member '(0 . "MLINE") edata)
(and
(member '(0 . "POLYLINE") edata); "heavy" type
(/= (logand 88 (cdr (assoc 70 edata))) 0); 8 = 3DPoly, 16 or 64 = mesh
); and
(not (vlax-curve-isPlanar ent)); 3D Spline
); or
(ssdel ent ss); then -- remove [returns reduced ss]
(if (vlax-curve-isClosed ent); else -- for Circle, closed Pline/Ellipse/Spline
(setq closed T); then -- marker for both-ways question later
T ; else [for non-nil return from (repeat) if last object is open]
); if [else]
); if
); repeat
(> (sslength ss) 0); valid object(s) remaining
); and
(progn ; then -- proceed
(mapcar 'setvar svnames (list 0 0 1 1 0 *bufferdist)); set System Variables
(if closed ; any remaining viable object(s) closed?
(progn
(initget "Both Outboard")
(setq *buffersides ; global variable
(cond
( (getkword
(strcat
"\nFor closed object, offset Both ways or Outboard only? [Both/Outboard] : "
); strcat
); getkword
); User-input condition
(*buffersides); prior value if present on Enter
("Outboard"); initial-use default on Enter with no prior value **
; ** if "Both" preferred as initial default, EDIT in two places above
); cond
); setq
); progn
); if
(repeat (setq n (sslength ss))
(setq
new (ssadd); initially empty for each
obj (vlax-ename->vla-object (ssname ss (setq n (1- n))))
etype (substr (vla-get-ObjectName obj) 5); without AcDb prefix
closed (vlax-curve-isClosed obj); [re-use variable name]
); setq
(if (= etype "Ray")
(progn ; then [by pick because (vla-offset) method not available]
(setq ang
(angle
(vlax-get obj 'BasePoint)
(setq pton (vlax-get obj 'SecondPoint))
; [less subject to seeing something else than end]
); angle
pickoffs (list (getvar 'aperture) (getvar 'aperture))
); setq
(while ; find pick location where Offset pick finds only this Ray
(> (sslength (ssget "_C" (mapcar '+ pton pickoffs) (mapcar '- pton pickoffs))) 1)
; more than one thing within Osnap Aperture range?
(setq pton (polar pton ang 1)); then -- move along Ray
); while
(command "_.offset" "" pton (polar pton (- ang (/ pi 2)) *bufferdist) "")
(setq e1 (entlast)) (ssadd e1 new)
(command "_.offset" "" pton (polar pton (+ ang (/ pi 2)) *bufferdist) "")
(setq e2 (entlast)) (ssadd e2 new)
); progn -- then
(progn ; else [all other types]
(vla-offset obj *bufferdist); always outboard of Arc/Circle/Ellipse
(setq e1 (entlast))
(if
(and
closed
(= *buffersides "Outboard")
(vla-object e1)) (vla-get-Area obj)); went inboard
); and
(entdel e1); then -- remove [other-way Offset wanted]
(ssadd e1 new); else
); if
(if ; Offset other way when applicable:
(cond
((wcmatch etype "Line,Xline"))
((= etype "Arc") (> (vlax-get obj 'Radius) *bufferdist)); big enough
((= etype "Circle")
(and
(> (vlax-get obj 'Radius) *bufferdist); big enough
(= *buffersides "Both"); if asked for [always closed]
); and
); Circle condition
((= etype "Ellipse")
(and
(> (vlax-get obj 'MinorRadius) *bufferdist); big enough
(if closed (= *buffersides "Both") T)
); and
); Ellipse condition
((not closed)); open-ended Polyline/Spline
((= *buffersides "Both")); closed Polyline/Spline
((not (entget e1))); Outboard-only option with closed Polyline/Spline
; first one was inboard under Outboard-only option, so deleted
; [if (entget) succeeds, e1 was already outboard -- don't go other way]
); cond
(progn ; second Offset
(vla-offset obj (- *bufferdist))
(setq e2 (entlast)) (ssadd e2 new)
); progn
); if
); progn -- else [other than Ray]
); if [Ray or otherwise]
(if (and (not closed) (/= etype "Xline"))
; open-ended object other than Xline -- wrap Arcs around ends
(progn ; then
(command
"_.arc" (vlax-curve-getStartPoint e1) "_c" (vlax-curve-getStartPoint obj)
; [spelling out "_cen[ter]" is taken as Osnap call]
"_angle"
(strcat
(if (= etype "Line") "" "-")
(angtos pi (getvar 'aunits) 8); any Units angle settings
); strcat
); command
(ssadd (entlast) new)
(if (/= etype "Ray"); other end for all but Ray
(progn ; then
(command
"_.arc" (vlax-curve-getEndPoint e1) "_c" (vlax-curve-getEndPoint obj)
"_angle"
(strcat
(if (= etype "Line") "-" "")
(angtos pi (getvar 'aunits) 8); any Units angle settings
); strcat
); command
(ssadd (entlast) new)
); progn
); if [not Ray]
(if (wcmatch etype "*Polyline,Line,Arc"); connectable with Pedit
; [In older versions, Fit-curved or Spline-curved 2D Polyline will LOSE curvature
; if PEDIT/Joined; if an issue, replace above (if... line with:
; (if
; (or
; (wcmatch etype "Line,Arc,Polyline"); always PEDIT/Joinable without loss
; (and
; (= etype "2dPolyline")
; (= (vlax-get obj 'Type) 0); NOT Fit- or Spline-curved
; ); and
; ); or
; In newer versions, could use JOIN also with Spline, Ellipse or such Plines, BUT:
; JOIN when in a (command) function does NOT allow multiple initial selection
; as command-line version does, but requires selecting one object first, after which
; expectations vary with combinations of entity types, etc., e.g. if Line selected first,
; can't JOIN Arc to it, or vice versa. If desired to use JOIN with other entity types
; than Lines/Arcs/"plain" Polylines joinable via PEDIT, do it manually afterwards.
; [As of Acad2016 -- may change in later versions.]
(progn ; then
(command "_.pedit" "_multiple" new "" "_join" "" ""); connect them
(ssadd (entlast) new)
); progn
); if [Pedit-Joinable or not]
(if
(and
(wcmatch etype "Arc,Ellipse")
(not closed); if Ellipse, partial [i.e. not full with Outboard-only option]
(not e2); did not go inboard [radius not more than buffer width]
); and
(if (= etype "Arc"); then -- trim end-wrapping arcs if needed
(if (not (vlax-curve-isClosed (setq e1 (entlast)))); [re-use variable name]
; with close-enough ends, PEDIT/Join sometimes trims to closed, but if not:
(command "_.trim" e1 "" ; then
(vlax-curve-getStartPoint e1) (vlax-curve-getEndPoint e1) ""
); command
); if [joined-Polyline result around Arc]
(if ; else [open Ellipse -- buffer not joined]
(vlax-invoke
(setq e1 (vlax-ename->vla-object (ssname new 1))); [re-use variable names]
; 1st Arc [0 is outward-Offset Spline]
'IntersectWith ; Arcs cross? [won't always with Ellipses as with Arcs]
(setq e2 (vlax-ename->vla-object (ssname new 2))); 2nd
acExtendNone
); vlax-invoke
(command "_.trim" new "" ; then
(vlax-curve-getStartPoint e1) (vlax-curve-getEndPoint e2)
); command
); if
); if [Arc vs. Ellipse]
); if [may need wrap-around-end Arcs trimmed]
); progn -- then
); if [open-ended non-Xline or otherwise]
(command "_.chprop" new "" "_layer"
(if (= *bufferlay "Source") (vla-get-Layer obj) (getvar 'clayer)) ""
); command
); repeat [through selection set]
); progn -- then
(prompt "\nNo Offsettable object(s) selected."); else
; [whether because of object type(s) or locked Layer(s)]
); if [valid selection or not]

(mapcar 'setvar svnames svvals); reset
(vla-endundomark doc)
(princ)
); defun

(vl-load-com)
(prompt "\nType BUF to add buffer boundary outline(s) around object(s).")

(defun c:bf ()
(c:buf)
(c:pw)
(c:lts)
(c:chl)
)
;(c:bf)

Аннотативность в автокаде

Аннотативный объект, Автокад.

Аннотативные объекты автокадАннотативность в автокаде – свойство объекта, приводящее масштаб этого объекта в соответствие с масштабом видового экрана в пространстве «Лист». Она позволяет зафиксировать размер выводимого на печать элемента, не зависимо от масштаба. Аннотативность может присваиваться следующим объектам: размерам, тексту, допускам, штриховкам, блокам, мультивыноскам. Под катом разберемся с возможностями которые она даёт.

Грубо говоря, когда вы меняете масштаб видового экрана, картинка меняет размер, а аннотативный объект (текст, размер, блок, и др.) остаются в видовом экране на Листе неизменными.

Например, вы задали тексту быть на листе всегда 3,5мм, как бы вы не уменьшали весь чертеж, а текст будет всегда 3,5мм на Листе.


Аннотативный текст, автокад.

Аннотативный текст.

Сделаем объект аннотативным: выбираем вкладку на рабочей панели «Стили текста». Далее создаем новый стиль, и ставим галочку напротив «Аннотативный». Рядом «высота текста на листе» задаем высоту текста, которая нам нужна на листе. Теперь меняя масштаб видового экрана. Текст, напечатанный в этом текстовом стиле, будет всегда одинаковым на Листе.

Аннотативный размер, автокад.

Аннотативный размер, автокад.
Выбираем вкладку на рабочей панели «Размерные стили». Создаем новый слой, для которого не забываем ставить галочку напротив «Аннотативный». Теперь меняя масштаб видового экрана, размеры, находящиеся в этом стиле будут неизменны на Листе.

Аннотативный масштаб автокад, или почему аннотативный объект исчезает с видового экрана?

Если аннотативный масштаб не совпадает с масштабом данного видового экрана, то этот объект не отображается — исчезает.

Для того чтобы объект отображался на видовом экране необходимо в свойствах этого объекта (для текста вкладка «текст», для размеров вкладка «разное»), выбрать «Аннотативный масштаб» и в появившемся окне задать масштаб аннотаций. Плюсом является то, что можно для этого объекта задать сразу несколько масштабов – для того, что бы вдальнейшем, если вам понадобится поменять масштаб этот объект не исчез с видового экрана. Так что сразу смело выставляйте все предполагаемые для этого объекта масштабы.

Change Linetype of selected blocks entities and attributes to continuous


;;; Change Linetype of selected blocks entities and attributes to continuous
;;; Based on FIXBLOCK.LSP
;;; Modified by Igal Averbuh 2018

(defun d_FixBlock (/ eBlockSel ; Block selection
lInsertData ; Entity data
sBlockName ; Block name
lBlockData ; Entity data
eSubEntity ; Sub-entity name
lSubData ; Sub-entity data
iCount ; Counter
)

;; Redefine error handler

(setq
d_#error *error*
*error* d_FB_Error
) ;_ end setq

;; Set up environment

(setq #SYSVARS (#SaveSysVars (list "cmdecho")))

(setvar "cmdecho" 0)
(command "._undo" "_group")

;; Get block from user and make sure it's an INSERT type

(if (setq eBlockSel (entsel "\nSelect block to change :"))
(progn
(if (setq lInsertData (entget (car eBlockSel)))
(if (= (cdr (assoc 0 lInsertData)) "INSERT")
(setq sBlockName (cdr (assoc 2 lInsertData)))
(progn
(alert "Entity selected is not a block!")
(exit)
) ;_ end progn
) ;_ end if
(progn
(alert "Invalid Block Selection!")
(exit)
) ;_ end progn
) ;_ end if

;; Get block info from the block table

(setq
lBlockData (tblsearch "BLOCK" sBlockName)
eSubEntity (cdr (assoc -2 lBlockData))
) ;_ end setq

;; Make sure block is not an Xref

(if (not (assoc 1 lBlockData))
(progn
(princ "\nProcessing block: ")
(princ sBlockName)

(princ "\nUpdating blocks sub-entities. . .")

;; Parse through all of the blocks sub-entities

(while eSubEntity

(princ " .")
(setq lSubData (entget eSubEntity))

;; Update the linetype property

(if (assoc 6 lSubData)
(progn
(setq lSubData
(subst
(cons 6 "CONTINUOUS")
(assoc 6 lSubData)
lSubData
) ;_ end subst
) ;_ end setq
(entmod lSubData)
) ;_ end progn
(entmod (append lSubData (list (cons 6 "CONTINUOUS"))))
) ;_ end if

(setq eSubEntity (entnext eSubEntity))
; get next sub entity

) ; end while

;; Update attributes

(idc_FB_UpdAttribs)

) ; end progn
(alert "XREF selected. Not updated!")
) ; end if
) ; end progn
(alert "Nothing selected.")
) ; end if

;;; Pop error stack and reset environment

(idc_RestoreSysVars)

(princ "\nDone!")

(setq *error* d_#error)

(princ)

) ; end defun

;*******************************************************************************
; Function to update block attributes
;*******************************************************************************
(defun idc_FB_UpdAttribs ()

;; Update any attribute definitions

(setq iCount 0)

(princ "\nUpdating attributes. . .")
(if (setq ssInserts (ssget "x"
(list (cons 0 "INSERT")
(cons 66 1)
(cons 2 sBlockName)
) ;_ end list
) ;_ end ssget
) ;_ end setq
(repeat (sslength ssInserts)

(setq eBlockName (ssname ssInserts iCount))

(if (setq eSubEntity (entnext eBlockName))
(setq
lSubData (entget eSubEntity)
eSubType (cdr (assoc 0 lSubData))
) ;_ end setq
) ;_ end if

(while (or (= eSubType "ATTRIB") (= eSubType "SEQEND"))

;; Update the linetype property

(if (assoc 6 lSubData)
(progn
(setq lSubData
(subst
(cons 6 "CONTINUOUS")
(assoc 6 lSubData)
lSubData
) ;_ end subst
) ;_ end setq
(entmod lSubData)
) ;_ end progn
(entmod (append lSubData (list (cons 6 "CONTINUOUS"))))
) ;_ end if

(if (setq eSubEntity (entnext eSubEntity))
(setq
lSubData (entget eSubEntity)
eSubType (cdr (assoc 0 lSubData))
) ;_ end setq
(setq eSubType nil)
) ;_ end if

) ; end while

(setq iCount (1+ iCount))

) ; end repeat

) ; end if
(command "regen")
) ; end defun

;*******************************************************************************
; Function to save a list of system variables
;*******************************************************************************
(defun #SaveSysVars (lVarList / sSystemVar)
(mapcar
'(lambda (sSystemVar)
(setq lSystemVars
(append lSystemVars
(list (list sSystemVar (getvar sSystemVar)))
) ;_ end append
) ;_ end setq
) ;_ end lambda
lVarList
) ;_ end mapcar

lSystemVars

) ;_ end defun
;*******************************************************************************
; Function to restore a list of system variables
;*******************************************************************************
(defun idc_RestoreSysVars ()
(mapcar
'(lambda (sSystemVar)
(setvar (car sSystemVar) (cadr sSystemVar))
) ;_ end lambda
#SYSVARS
) ;_ end mapcar
) ;_ end defun
;*******************************************************************************
; Error Handler
;*******************************************************************************
(defun d_FB_Error (msg)

(princ "\nError occurred in the Fix Block routine...")
(princ "\nError: ")
(princ msg)

(setq *error* d_#error)
(if *error*
(*error* msg)
) ;_ end if

(command)

(if (/= msg "quit / exit abort")
(progn
(command "._undo" "_end")
(command "._u")
) ;_ end progn
) ;_ end if

(idc_RestoreSysVars)

(princ)

) ;_ end defun
;*******************************************************************************

(defun C:LX () (d_FixBlock))
(princ)

Select entities by color property. (Routine allows from a pick in just one entity, select all entities in drawing that have the same color property)


;;; Select entities by color property
;;; Routine allows from a pick in just one entity, select all entities in drawing that have the same color property.
;;; Created by Lee Mac
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?62842-Select-entities-by-color-property.

(defun c:fbc ( / c d e l )
(if (setq e (car (entsel)))
(progn
(setq c
(cond
( (cdr (assoc 62 (entget e))) )
( (abs (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 (entget e))))))) )
)
)
(while (setq d (tblnext "LAYER" (null d)))
(if (= c (abs (cdr (assoc 62 d))))
(setq l (cons "," (cons (cdr (assoc 2 d)) l)))
)
)
(sssetfirst nil
(ssget "_X"
(if l
(list
(cons -4 "<OR")
(cons 62 c)
(cons -4 "")
(cons -4 "OR>")
)
(list (cons 62 c))
)
)
)
)
)
(princ)
)
(c:fbc)

AutoCAD Drawing Version determination (Updated Lee Mac routine for AutoCAD 2018-2019 releases)


;; Drawing Version - Lee Mac
;; Returns the version of the supplied filename (dwg/dws/dwt/dxf)
;; Updated for 2018 - 2019 Autocad versions by Igal Averbuh 2018
(defun LM:dwgversion ( fn / fd vr )
(cond
( (null
(and
(setq fn (findfile fn))
(setq fd (open fn "r"))
)
)
)
( (wcmatch (strcase fn t) "*`.dw[gst]")
(setq vr (strcase (substr (read-line fd) 1 6)))
)
( (wcmatch (strcase fn t) "*`.dxf")
(repeat 7 (read-line fd))
(setq vr (strcase (read-line fd)))
)
)
(if (= 'file (type fd)) (close fd))
(cdr
(assoc vr
'(
("AC1032" . "2018-2019")
("AC1027" . "2013-2015")
("AC1024" . "2010-2012")
("AC1021" . "2007-2009")
("AC1018" . "2004-2006")
("AC1015" . "2000-2002")
("AC1014" . "Release 14")
("AC1012" . "Release 13")
("AC1009" . "Release 11/12")
("AC1006" . "Release 10")
("AC1004" . "Release 9")
("AC1003" . "Release 2.60")
("AC1002" . "Release 2.50")
("AC1001" . "Release 2.22")
("AC2.22" . "Release 2.22")
("AC2.21" . "Release 2.21")
("AC2.10" . "Release 2.10")
("AC1.50" . "Release 2.05")
("AC1.40" . "Release 1.40")
("AC1.2" . "Release 1.2")
("MC0.0" . "Release 1.0")
)
)
)
)

;; Prints the version of the active drawing file

(defun c:dwgver ( / vr )
(if (zerop (getvar 'dwgtitled))
(princ "\nThe current drawing is unsaved.")
(if (setq vr (LM:dwgversion (strcat (getvar 'dwgprefix) (getvar 'dwgname))))
(princ (strcat "\nThis is an AutoCAD " vr " format file."))
(princ "\nThe format of this file could not be determined.")
)
)
(princ)
)
(c:dwgver)

Change Color of selected objects to used defined Index color number


;;; Change Color of selected objects to used defined Index color number
;;; Created by Lee Mac
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?31679-Simple-colour-change-lisp
;;; Slightly modified by Igal Averbuh 2018 (changed priority of some commands)

(defun c:coc (/ usercol ss)
(prompt "Select objects to change color:")
(setq ss (ssget))
(setq usercol (acad_colordlg 256))
(command "_.ChProp" ss "" "_C" usercol "")
(princ))

(c:coc)

Change Color of selected objects to used defined Index color number or via dialog box


;;; Change Color of selected objects to used defined by Index color number or via dialog box
;;; Created by neophoible
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?81744-Selected-Objects-to-color-LISP/page2

(defun C:COC (/ ColorObjects CurrColorOrg NewColor CmdEchoOrg)
(prompt "\nSelect objects to change color...")
(cond
( (setq ColorObjects (ssget))
(setq CurrColorOrg (getvar 'CECOLOR)
CmdEchoOrg (getvar 'CMDECHO)
)
(setvar 'CMDECHO 0)
(while
(not (cond
( (initget 6) )
( (setq NewColor (getint
"\nEnter object color (1-255) : "
) )
(if (< NewColor 256) (setvar 'CECOLOR (itoa NewColor)))
)
(T(initdia)
(command "_.COLOR")
(numberp (read (getvar 'CECOLOR)))
)
) )
(prompt "\nCannot set color to that value.\n*Invalid.*")
)
(command "_.CHANGE" ColorObjects "" "_P" "_C" (getvar 'CECOLOR) "")
) )
(setvar 'CECOLOR CurrColorOrg)
(setvar 'CMDECHO CmdEchoOrg)
(princ)
)
(c:coc)

Remove background color from all hatches at once


; Remove background color from all hatches at once

; Created by Igal Averbuh 2015 (based on existing routines)

;;Recreate-Hatch-Boundaries.lsp written by Murray Clack, November 19, 2010
;;;Recreate multiple hatch boundaries as polygons, each in the layer as his hach.
(prompt "\nRecreate-Hatch-Boundaries.lsp loaded, Enter HB to execute")
(defun c:HB (/ OLDCE SSET CNT OBJ)
(setq OLDCE (getvar "cmdecho"))
(setvar "cmdecho" 0)
;(princ "\nSelect Hatch Objects: ")
;(setq SSET (ssget))
(setq SSET (ssget "X" '((0 . "HATCH"))))
(setq CNT -1)
(while (setq OBJ (ssname SSET (setq CNT (1+ CNT))))
(setvar 'clayer (cdr (assoc 8 (entget OBJ))))
(command "-hatchedit" OBJ "b" "p" "n")
)
(setvar "cmdecho" OLDCE)
(princ)
)

(defun c:hed()
(initcommandversion)
(command "-hatchedit" "P" "" "CO" "" ".")

(princ)
)

(defun C:ras (/ SETD LAY)

(setvar "CMDECHO" 0)

(setq SETD (ssget "X" '((0 . "HATCH"))))

(if (null SETD)

(princ "\nThere are no associated hatches.")

(progn

(c:hed)
(c:hb)
(command "regen")
)

)

(setvar "CMDECHO" 1)

(princ)

)

(C:ras)