Linear Texts and Attributes Interpolation in a Horizontal plan


; Linear Interpolation in a Horizontal plan
; Based on: http://www.autocadproblems.com/2014/09/marking-level-on-plan-autocad.html
; Slightly modified by Igal Averbuh 2017
; Modified by Master Kent Cooper 2017 (added option for Attributes and nested texts)
; Saved from here: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/linear-interpolation-problem/m-p/6962404/highlight/false#M351363
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:hi()

(princ "\nNeed to disable WinHEB in order to work with this program\n")
(defun LayerPurgePrevention (dictName layerNameList / layerEnameList)
(dictremove (namedobjdict) dictName)
(if
(setq layerEnameList
(vl-remove
nil
(mapcar
'(lambda (layerName) (tblobjname "layer" layerName))
layerNameList
)
)
)
(dictadd
(namedobjdict)
dictName
(entmakex
(vl-list*
'(0 . "XRECORD")
'(100 . "AcDbXrecord")
(mapcar
'(lambda (layerEname) (cons 340 layerEname))
layerEnameList
)
)
)
)
)
)
(setvar "cmdecho" 0)
(command "-layer" "m" "000-Interpolate Text Labels" "")

(LayerPurgePrevention "OnsBedrijfLayerPurgePrevention" '("000-Interpolate Text Labels"))

(command "-style" "Igal" "Arial.ttf" "0" "" "" "" "")

(setvar 'textsize
(cond ((getdist (strcat "\nSpecify Text Height : ")))
((getvar 'textsize))
)
)

(setq GL1 (nentsel "\nSelect First Boundary Text Value:"))

(setq Lvl1 (entget (car GL1)))

(setq G_val1 (assoc 1 Lvl1))

(setq GL2 (nentsel "\nSelect Second Boundary Text Value:"))

(setq Lvl2 (entget (car GL2)))

(setq G_Val2 (assoc 1 Lvl2))

(setq p1 (getpoint "Pick Point Range From:"))
(setq d (getdist p1 "Pick Point Range To:"))
(setq d (float d))

(setq slp1 (- (atof(cdr G_val2)) (atof(cdr G_val1))))
(setq slp (/ slp1 d))

(while
(setq Txt_Pnt (getpoint "\nPick on Interpolate Point in Range..:"))
(setq d1 (distance p1 Txt_pnt))
(setq new_lvl (+ (atof(cdr G_val1)) (* d1 slp)))
(setq val1 (rtos new_lvl 2 2))
(command "text" Txt_pnt "" "" val1)
)
)
(c:hi)

Linear Interpolation in a Horizontal plan


; Linear Interpolation in a Horizontal plan
; Based on: http://www.autocadproblems.com/2014/09/marking-level-on-plan-autocad.html
; Slightly modified by Igal Averbuh 2017
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:hi()

(princ "\nNeed to disable WinHEB in order to work with this program\n")
(defun LayerPurgePrevention (dictName layerNameList / layerEnameList)
(dictremove (namedobjdict) dictName)
(if
(setq layerEnameList
(vl-remove
nil
(mapcar
'(lambda (layerName) (tblobjname "layer" layerName))
layerNameList
)
)
)
(dictadd
(namedobjdict)
dictName
(entmakex
(vl-list*
'(0 . "XRECORD")
'(100 . "AcDbXrecord")
(mapcar
'(lambda (layerEname) (cons 340 layerEname))
layerEnameList
)
)
)
)
)
)
(setvar "cmdecho" 0)
(command "-layer" "m" "000-Interpolate Text Labels" "")

(LayerPurgePrevention "OnsBedrijfLayerPurgePrevention" '("000-Interpolate Text Labels"))

(command "-style" "Igal" "Arial.ttf" "0" "" "" "" "")

(setvar 'textsize
(cond ((getdist (strcat "\nSpecify Text Height : ")))
((getvar 'textsize))
)
)

(while (not
(setq GL1 (entsel "\nSelect First Boundary Text Value:"))
))
(setq Lvl1 (entget (car GL1)))

(if (> (length Lvl1) 22)
(setq G_val1 (nth 13 Lvl1))

(setq G_Val1 (nth 11 Lvl1))
)

(while (not
(setq GL2 (entsel "\nSelect Second Boundary Text Value:"))
))
(setq Lvl2 (entget (car GL2)))

(if (> (length Lvl2) 22)
(setq G_val2 (nth 13 Lvl2))

(setq G_Val2 (nth 11 Lvl2))
)

(setq p1 (getpoint "Pick Point Range From:"))
(setq d (getdist p1 "Pick Point Range To:"))
(setq d (float d))

(setq slp1 (- (atof(cdr G_val2)) (atof(cdr G_val1))))
(setq slp (/ slp1 d))

(while
(setq Txt_Pnt (getpoint "\nPick on Interpolate Point in Range..:"))
(setq d1 (distance p1 Txt_pnt))
(setq new_lvl (+ (atof(cdr G_val1)) (* d1 slp)))
(setq val1 (rtos new_lvl 2 3))
(command "text" Txt_pnt "" "" val1)
)
)
(c:hi)

Automatic Coordinate Labeling (Draw Leader with X,Y coordinates in 000-Coordinates Labels layer)


;;; Automatic Coordinate Labeling (Draw Leader with X,Y coordinates in 000-Coordinates Labels layer)
;;; User can define: Leader Arrow Head Size, Coordinates Text Height and Coordinates Text Location
;;; Created by Igal Averbuh 2017
;;;Based on C.Gingerich and Edwin Prakoso Programs.

(defun c:XY (/ txtsz st midpt endpt htxts ang1 ang2 pt1 pt2 scle
arblk tsize)

(princ "\nNeed to disable WinHEB in order to work with this program\n")
(defun LayerPurgePrevention (dictName layerNameList / layerEnameList)
(dictremove (namedobjdict) dictName)
(if
(setq layerEnameList
(vl-remove
nil
(mapcar
'(lambda (layerName) (tblobjname "layer" layerName))
layerNameList
)
)
)
(dictadd
(namedobjdict)
dictName
(entmakex
(vl-list*
'(0 . "XRECORD")
'(100 . "AcDbXrecord")
(mapcar
'(lambda (layerEname) (cons 340 layerEname))
layerEnameList
)
)
)
)
)
)
(setvar "cmdecho" 0)
(command "-layer" "m" "000-Coordinates Labels" "")

(LayerPurgePrevention "OnsBedrijfLayerPurgePrevention" '("000-Coordinates Labels"))

(setvar "cmdecho" 1)

(setq st nil
midpt nil
endpt nil)
(defun *error* (ms)
(setvar "orthomode" *ortho)
(setq tsize (getvar "textsize"))
(princ ms)
(princ)
)
(setvar "cmdecho" 0)
(setq tsize (getvar "textsize"))
(setq *ortho (getvar "orthomode"))
(setq scle (getvar "dimscale"))
(setvar "orthomode" 0)

(setvar 'DIMASZ
(cond ((getdist (strcat "\nSpecify Leader Arrow Head Size : ")))
((getvar 'DIMASZ))
)
)

(setvar 'textsize
(cond ((getdist (strcat "\nSpecify Coordinates Text Height : ")))
((getvar 'textsize))
)
)

(while
(setvar "orthomode" 0)
(setq st (getpoint "\nPick Coordinates Point: "))

(if (= st nil)(exit))
(setq midpt (getpoint st))
(setvar "orthomode" 1)
(if (= midpt nil)(exit))
(setq endpt (getpoint midpt))
(if (= endpt nil)(exit))
(command "leader" st midpt endpt "" "" "n")
(setvar "orthomode" *ortho)

(setq textloc (getpoint "\nPick Coordinates Text Location: "))

(command "-style" "Igal" "Arial.ttf" "0" "" "" "" "")

(setq x (rtos (car st)))
(setq y (rtos (cadr st)))
; (setq ptcoord (strcat "X= " x " " "Y= " y))
(setq ptcoordx (strcat "X= " x))
(setq ptcoordy (strcat "Y= " y))
(command "_.text" "j" "bl" textloc "" "" ptcoordx )
(command "_.text" "" ptcoordy)

)
)
;(c:xy)

Draw quick leader arrow


(defun c:LA (/ _group _dist lastentity p1 p2 ent obj gr coords pt)
;; Draw quick leader arrow
;; Alan J. Thompson, 03.13.11
;; Slightly modified by Igal Averbuh 2017 (added option to Specify Arrow Head Size)
(vl-load-com)

(setvar 'DIMASZ
(cond ((getdist (strcat "\nSpecify Arrow Head Size : ")))
((getvar 'DIMASZ))
)
)

(defun _group (l)
(if (caddr l)
(cons (list (car l) (cadr l) (caddr l)) (_group (cdddr l)))
)
)

(defun _dist (a b) (distance (list (car a) (cadr a)) (list (car b) (cadr b))))

(setq lastentity (entlast))
(if (and (setq p1 (getpoint "\nSpecify first point: "))
(setq p2 (getpoint p1 "\nSpecity next point: "))
(vl-cmdf "_.leader" "_non" p2 "_non" p1 "" "" "_N")
(not (equal lastentity (setq ent (entlast))))
(setq obj (vlax-ename->vla-object ent))
)
(while (eq 5 (car (setq gr (grread T 15 0))))
(redraw)
(grdraw (cadr gr)
(trans (vlax-curve-getClosestPointTo ent (setq pt (trans (cadr gr) 1 0))) 0 1)
3
-1
)
(if
(equal
(last (setq coords (_group (vlax-get obj 'Coordinates))))
(car (vl-sort coords (function (lambda (a b) (< (_dist a pt) (_dist b pt))))))
)
(vlax-put obj 'Coordinates (apply (function append) (reverse coords)))
)
(grdraw (cadr gr) (trans (car coords) 0 1) 1 -1)
)
)
(redraw)
(princ)
)
(c:la)

Kent Cooper Leader Zero Rotation


;;; Leader Zero Rotation

(defun C:LZR ; Kent Cooper Rotate Leader(s) about first Bend, 2nd leg Horizontal
(/ ss ldr pts23 base refang)
(if (setq ss (ssget "_:L" '((0 . "LEADER"))))
(repeat (setq n (sslength ss))
(setq
ldr (ssname ss (setq n (1- n))); Leader entity
pts23 ; defining points 2 & 3
(cdr ; remove first one [arrow point]
(mapcar 'cdr ; remove 10's [leave coordinates only]
(vl-remove-if
'(lambda (x) (/= (car x) 10))
(entget ldr)
); ...remove...
); mapcar
); cdr & pts23
); setq
(command "_.rotate" ldr ""
(setq base (trans (car pts23) 0 1)); (trans)lated from WCS to current UCS
"_reference" (angtos (setq refang (angle base (trans (cadr pts23) 0 1))) 2 8)
(angtos (* (fix (+ (/ refang pi) 0.5)) pi) 2 8); nearer horizontal direction
); command
); repeat
); if
(princ)
); defun
(c:lzr)

Time of When Object was Modified ( Lee Mak approach)


;; Last Modification Logging Utility - Lee Mac
;; Stores the username/date/command as xdata attached to every modified object.
;; Saved from: http://www.cadtutor.net/forum/showthread.php?89950-xdata-to-save-info-who-last-modified-objects&p=615831&viewfull=1#post615831

;; Type 'LASTMODON' to enable modification logging, and 'LASTMODOFF' to disable logging.

;; Type 'LASTMOD' to view the last modification data for an object.

;; Type 'LASTMODCLEAR' to remove the logged modification data for a set of objects.

(setq lastmod:appid "LMAC_lastmod")

(defun c:lastmod ( / ent lst )
(while
(progn (setvar 'errno 0) (setq ent (car (entsel "\nSelect object to view modification data : ")))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (null ent) nil)
( (null (setq lst (mapcar 'cdr (cdadr (assoc -3 (entget ent (list lastmod:appid)))))))
(princ "\nSelected object does not contain modification data.")
)
( (princ (strcat "\nObject last modified by " (car lst) " at " (cadr lst) " using the " (caddr lst) " command.")))
)
)
)
(princ)
)
(defun c:lastmodclear ( / idx sel )
(if (setq sel (ssget "_:L" (list (list -3 (list lastmod:appid)))))
(repeat (setq idx (sslength sel))
(entmod (append (entget (ssname sel (setq idx (1- idx)))) (list (list -3 (list lastmod:appid)))))
)
)
(princ)
)
(defun c:lastmodon nil
(lastmod:remove)
(vlr-command-reactor "lastmod"
'(
(:vlr-commandwillstart . lastmod:com:start)
(:vlr-commandended . lastmod:com:ended)
(:vlr-commandcancelled . lastmod:com:clear)
(:vlr-commandfailed . lastmod:com:clear)
)
)
(setq lastmod:obj:rtr
(vlr-object-reactor
( (lambda ( sel / idx lst )
(if sel
(repeat (setq idx (sslength sel))
(setq lst (cons (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) lst))
)
)
)
(ssget "_X")
)
"lastmod"
'(
(:vlr-modified . lastmod:obj:modified)
(:vlr-subobjmodified . lastmod:obj:modified)
)
)
)
(regapp lastmod:appid)
(princ "\nObject modification logging enabled.")
(princ)
)
(defun c:lastmodoff nil
(lastmod:remove)
(princ "\nObject modification logging disabled.")
(princ)
)
(defun lastmod:remove nil
(foreach obj (apply 'append (mapcar 'cdr (vlr-reactors :vlr-object-reactor :vlr-command-reactor)))
(if (= "lastmod" (vlr-data obj)) (vlr-remove obj))
)
(setq lastmod:obj:rtr nil
lastmod:entlast nil
lastmod:objlist nil
)
)
(defun lastmod:obj:modified ( obj rtr arg )
(setq lastmod:objlist (cons obj lastmod:objlist))
(princ)
)
(defun lastmod:com:start ( rtr com / tmp )
(setq lastmod:entlast (entlast))
(while (setq tmp (entnext lastmod:entlast))
(setq lastmod:entlast tmp)
)
(princ)
)
(defun lastmod:com:ended ( rtr com / ent obj )
(setq com (strcase (car com))
ent (if lastmod:entlast (entnext lastmod:entlast) (entnext))
)
(foreach obj lastmod:objlist
(lastmod:addxdata (vlax-vla-object->ename obj) com)
)
(while ent
(if (vlax-write-enabled-p (setq obj (vlax-ename->vla-object ent)))
(progn
(lastmod:addxdata ent com)
(vlr-owner-add lastmod:obj:rtr obj)
)
)
(setq ent (entnext ent))
)
(setq lastmod:objlist nil
lastmod:entlast nil
)
(princ)
)
(defun lastmod:clear ( rtr arg )
(setq lastmod:objlist nil
lastmod:entlast nil
)
(princ)
)
(defun lastmod:addxdata ( ent com / enx )
(if (and (= 'ename (type ent))
(setq enx (entget ent))
(not (wcmatch (cdr (assoc 0 enx)) "VERTEX,ATTRIB,SEQEND"))
)
(entmod
(append (entget ent)
(list
(list -3
(list lastmod:appid
(cons 1000 (getvar 'loginname))
(cons 1000 (menucmd "m=$(edtime,0,yyyy-mo-dd hh:mm:ss)"))
(cons 1000 com)
)
)
)
)
)
)
)
(vl-load-com) (princ)

Change Properties of selected object same to properties of nested object (Master BeekeeCZ solution)


;;; Change Properties of selected object same to properties of nested object (Master BeekeeCZ solution)
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/match-properties-from-nested-item-is-it-possible/td-p/6915286

(defun c:nmp (/ nensel enlast)

(if (and (setq nensel (entsel "Select nested source object: "))
(setq enlast (entlast))
)
(progn
(command "_.NCOPY" (cadr nensel) "" "_none" '(0 0 0) "_none" '(0 0 0))
(if (not (equal enlast (entlast)))
(progn
(command "_.MATCHPROP" (nentselp (cadr nensel)))
(while (> (getvar 'CMDACTIVE) 0)
(command PAUSE))
(entdel (entlast))))))
(princ)
)
(c:nmp)

Lee Mac modified Elevation Marker (added predefined text style, Create UCS for 0.00 Elevation, option to change level marker scale according to Elevation marker text height)


;;-----------------------=={ Elevation Marker }==-----------------------;;
;; ;;
;; This program continuously prompts the user to specify a point and ;;
;; constructs an elevation marker composed of a variable width ;;
;; polyline & single-line text object at the specified point, with ;;
;; the text content displaying the UCS Y-coordinate of the point. ;;
;; ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;

;;; Slightly modified by Igal Averbuh 2017 (added predefined text style, Create UCS for 0.00 Elevation, option to change level marker scale
;;; according to Elevation marker text height

(defun c:em ( / *error* ang hgt len ocs pt1 pt2 pt3 pt4 str )

(setvar "DIMDEC" 2)

(setvar "DIMZIN" 2)

(command "-style" "igal" "arial.ttf" "" "" "0" "" "")

(setq p (getpoint "\nPick Point for 0.00 Level: "))

(command ".UCS" "Origin" p)

(setvar 'textsize
(cond ((getdist (strcat "\nSpecify Elevation text height by two points on screen : ")))
((getvar 'textsize))
)
)

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

(setq hgt (getvar 'textsize)
ocs (trans '(0.0 0.0 1.0) 1 0 t)
ang (angle '(0.0 0.0) (trans (getvar 'ucsxdir) 0 ocs t))
)
(terpri)
(while (setq pt1 (getpoint "\rSpecify point : "))
(setq str (rtos (cadr pt1))
len (strlen str)
pt2 (list (car pt1) (+ (cadr pt1) (* hgt 0.5 (sqrt 3))))
pt3 (list (- (car pt1) (* hgt len)) (cadr pt2))
pt4 (list (- (car pt2) (* hgt 0.5 len)) (+ (cadr pt2) hgt))
)
(foreach sym '(pt1 pt2 pt3 pt4)
(set sym (trans (eval sym) 1 ocs))
)
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 3)
'(070 . 0)
(cons 038 (caddr pt1))
(cons 010 pt1)
'(040 . 0.0)
(cons 041 hgt)
(cons 010 pt2)
(cons 040 (* hgt 0.05))
(cons 041 (* hgt 0.05))
(cons 010 pt3)
(cons 210 ocs)
)
)
(entmake
(list
'(000 . "TEXT")
(cons 007 (getvar 'textstyle))
(cons 001 str)
(cons 050 ang)
(cons 040 hgt)
(cons 010 pt4)
(cons 011 pt4)
'(072 . 1)
'(073 . 2)
(cons 210 ocs)
)
)
)
(princ)
)
(c:em)