Equal Xref Names in drawing to External Xref Names (Lee Mac Program) according to xrefs status (loaded/unloaded)


(vl-load-com)
;;; Equal Xref Names in drawing to External Xref Names (Lee Mac Program) according to xrefs status (loaded/unloaded)
;;; Combined and modified by Igal Averbuh 2016 (added respect to xref status)

(defun c:edu (/ str1 str2 str3 str4 fil1)
(setq str1 (getvar "dwgprefix")
str2 (getvar "dwgname")
str3 (vl-filename-base str2)
str4 (getvar "tempprefix"))
(setq fil1 (open (strcat str4 "open.scr") "w"))
(write-line "_close n" fil1)
(write-line (strcat "open " (strcat "\""str1 str3 ".dwg\"")) fil1)
(close fil1)
(command "script" (strcat str4 "open.scr"))
(princ)
)

(defun c:rai (/)
(vl-load-com)
(vl-cmdf "_.-image" "r" "*")
(princ)
)

(defun c:ein ( / dic img itm lst )
(if (setq lst (dictsearch (namedobjdict) "acad_image_dict")
dic (cdr (assoc -1 lst))
)
(while (setq lst (member (assoc 3 lst) lst))
(setq itm (cdr (assoc 3 lst))
img (vl-filename-base (cdr (assoc 1 (entget (cdr (assoc 350 lst))))))
lst (cdr lst)
)
(if (not (or (= img itm) (dictsearch dic img)))
(dictrename dic itm img)
)
)
)
(princ)
)

(defun c:exn (/ name)
(vlax-For blk (vla-Get-Blocks
(vla-Get-ActiveDocument (vlax-Get-Acad-Object))
)
(if
(and
(= (vla-Get-IsXref blk) :vlax-True)
(not
(wcmatch (vla-get-Name blk)
(setq
name (vl-filename-base (setq path (vla-get-path blk)))
)
)
)
)
(if
(not
(vl-catch-all-error-p
(vl-catch-all-apply '(lambda () (vla-put-Name blk name)))
)
)
()
)
)
)
(princ)

)

(c:ein)
(c:rai)
(c:exn)
;(command "_qsave")
(c:edu)

Reload all LOADED Xrefs and retain xref’s colours


;;; Reload all Loaded Xrefs and retain xref's colours
;;; Based on: http://www.cadtutor.net/forum/showthread.php?14319-Any-lisp-to-reload-only-quot-loaded-quot-xrefs

(defun c:ur(/ cObj cName)

(setvar "cmdecho" 0)

(setvar "visretain" 0)

(setq cObj(tblnext "BLOCK" T))
(while cObj
(setq cName(cdr(assoc 2 cObj)))
(if
(and
(=(logand(cdr(assoc 70 cObj))32)32)
(=(logand(cdr(assoc 70 cObj))4)4)
); end and
(progn
(vl-cmdf "_.xref" "_unload" cName)
(vl-cmdf "_.xref" "_reload" cName)
); end progn
); wnd if
(setq cObj(tblnext "BLOCK"))
); end while
(princ)
); end of c:unreload
(setvar "visretain" 1)

(setvar "cmdecho" 1)
(c:ur)

Serial Number and Date Check


;;; Serial Number and Date Check
;;; Combined from existing subroutines and modified by Igal Averbuh 2016

(defun c:sr()
(setq run (getvar "_pkser"))
(if (or (= run "392-67763891")(= run "392-67763892")) ;Change to the serial numbers you wanted.
(princ "\nSecurity check passed")
(progn
(princ "\nYou have tried to run XYZ SOFTWARE on a non authorised machine")
(princ "\nPlease contact me on 1234567 and I will rip your arms off")
)
)
(setq lastday 20180508.0) ;Change to the date you wanted. Now the date is 05.08.2018
(print "Checking date ... ")
(if (> (getvar "CDATE") lastday)
(progn
(princ "This program has expired.")
(quit)
)
(progn
(princ (strcat "You've still got " (itoa (fix (- lastday (getvar "CDATE")))) " day(s) to run this program ... "))
)
)
(princ "Program loaded.")

;; Continue with the rest of the code
(princ)
)
(c:sr)
;;;-----------------------------------------------------------------

Draw Floor Heating Pipe Author: Lee Mac, Copyright © 2013 – www.lee-mac.com


;;----------------------------=={ Heat Grid }==-------------------------;;
;; ;;
;; Prompts the user to select a rectangular closed LWPolyline and ;;
;; specify a grid wire spacing, and proceeds to construct a maximised ;;
;; filleted spiral centered within the selected LWPolyline based on ;;
;; the given wire spacing. ;;
;; ;;
;; The program will perform successfully with rectangular LWPolylines ;;
;; at any rotation or orientation, and with all UCS & Views. ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;

(defun c:hd ( / 2pi a1 a2 bl d2 di en h1 h2 ix l1 l2 l3 mt no p1 p2 pi2 rm tv v1 vl w1 w2 zv )
(setq pi2 (/ pi 2.0)
2pi (+ pi pi)
)
(while
(progn
(setvar 'errno 0)
(setq en (car (entsel "\nSelect Rectangular Closed LWPolyline: ")))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (= 'ename (type en))
(if (null (LM:rectangle-p en))
(princ "\nObject must be a Rectangular Closed LWPolyline.")
)
)
)
)
)
(if (= 'ename (type en))
(progn
(setq vl
(apply 'append
(mapcar
(function
(lambda ( dx )
(if (= 10 (car dx))
(list (trans (cdr dx) en 1))
)
)
)
(entget en)
)
)
)
(setq a1 (angle (car vl) (cadr vl))
w1 (distance (car vl) (cadr vl))
h1 (distance (cadr vl) (caddr vl))
)
(if (< h1 w1)
(setq tv w1
w1 h1
h1 tv
a1 (+ a1 pi2)
)
)
(setq w2 w1
h2 h1
)
(while
(and
(progn
(initget 6)
(setq di
(getdist
(strcat "\nSpecify Wire Spacing"
(if *spacing* (strcat " : ") ": ")
)
)
)
(if (null di)
(setq di *spacing*)
(setq *spacing* di)
)
)
(progn
(setq no (fix (/ w2 di))
rm (rem w2 di)
)
(if (equal 0.0 rm 0.1)
(setq no (1- no)
rm (+ rm di)
)
)
(if (zerop (rem no 2))
(setq no (1- no)
rm (+ rm di)
)
)
(< no 2)
)
)
(princ "\nWire Spacing too large.")
)
(if (= 'real (type di))
(progn
(setq w2 (- w2 rm)
h2 (- h2 rm)
p1 (list (/ rm 2.0) (/ rm 2.0) 0.0)
l1 (list p1)
a2 pi2
ix 0
)
(repeat no
(setq p1 (polar p1 a2 (if (zerop (rem ix 2)) h2 w2))
l1 (cons p1 l1)
a2 (rem (- a2 pi2) 2pi)
ix (1+ ix)
)
(if (and (< 2 ix) (= 1 (rem ix 2)))
(setq w2 (- w2 di di)
h2 (- h2 di di)
)
)
)
(setq l1 (reverse l1)
w2 (- w1 rm di di)
h2 (- h1 rm di)
p1 (list (+ (/ rm 2.0) di) (/ rm 2.0) 0.0)
l2 (list p1)
a2 pi2
ix 0
)
(repeat (- no 2)
(setq p1 (polar p1 a2 (if (zerop (rem ix 2)) h2 w2))
l2 (cons p1 l2)
a2 (rem (- a2 pi2) 2pi)
ix (1+ ix)
)
(if (= ix 2)
(setq h2 (- h2 di))
(if (and (< 2 ix) (= 1 (rem ix 2)))
(setq w2 (- w2 di di)
h2 (- h2 di di)
)
)
)
)
(setq
v1
(mapcar '- (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) (car vl) (caddr vl))
(setq p2
(apply 'mapcar
(cons (function (lambda ( a b ) (/ (+ a b) 2.0)))
(mapcar
(function
(lambda ( x ) (apply 'mapcar (cons x l1)))
)
'(min max)
)
)
)
)
)
d2 (/ di 2.0)
bl (/ (sin (/ pi -8.0)) (cos (/ pi 8.0)))
l1
(apply 'append
(mapcar
(function
(lambda ( a b c )
(cond
( (null a)
(list b)
)
( (null c)
(list (polar b (angle b a) d2))
)
( (list (polar b (angle b a) d2) bl (polar b (angle b c) d2)))
)
)
)
(cons nil l1)
l1
(append (cdr l1) '(nil))
)
)
bl (- bl)
l2
(apply 'append
(mapcar
(function
(lambda ( a b c )
(cond
( (null a)
(list (polar b (angle b c) d2))
)
( (null c)
(list b)
)
( (list (polar b (angle b a) d2) bl (polar b (angle b c) d2)))
)
)
)
(cons nil l2)
l2
(append (cdr l2) '(nil))
)
)
zv (trans '(0.0 0.0 1.0) 1 0 t)
mt (list (list (cos a1) (- (sin a1))) (list (sin a1) (cos a1)))
v1 (mapcar '+ v1 (mapcar '- p2 (mxv mt p2)))
l3
(mapcar
(function
(lambda ( x )
(if (listp x)
(cons 10 (trans (mapcar '+ (mxv mt x) v1) 1 zv))
(cons 42 x)
)
)
)
(append l1 (list -1.0 (polar (last l1) (+ a2 pi) di) (polar (car l2) a2 di) 1.0) l2)
)
)
(entmake
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 090 (length (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) l3)))
'(070 . 0)
(cons 210 zv)
)
l3
)
)
)
)
)
)
(princ)
)

;; Rectangle-p - Lee Mac
;; Returns T if the supplied entity is a rectangular closed LWPolyline

(defun LM:rectangle-p ( e / a b c d )
(and
(= "LWPOLYLINE" (cdr (assoc 0 (setq e (entget e)))))
(= 4 (cdr (assoc 90 e)))
(= 1 (logand 1 (cdr (assoc 70 e))))
(LM:nobulge-p e)
(mapcar 'set '(a b c d)
(apply 'append
(mapcar '(lambda ( x ) (if (= 10 (car x)) (list (cdr x)))) e)
)
)
(LM:perp-p (mapcar '- a b) (mapcar '- a d))
(LM:perp-p (mapcar '- a b) (mapcar '- b c))
(LM:perp-p (mapcar '- a d) (mapcar '- c d))
)
)

;; Perpendicular-p - Lee Mac
;; Returns T if the supplied vectors are perpendicular

(defun LM:perp-p ( u v )
(equal 0.0 (apply '+ (mapcar '* u v)) 1e-8)
)

;; No Bulge-p - Lee Mac
;; Returns T if the supplied LWPolyline DXF list has zero bulge

(defun LM:nobulge-p ( e / p )
(or (not (setq p (assoc 42 e)))
(and (equal 0.0 (cdr p) 1e-8)
(LM:nobulge-p (cdr (member p e)))
)
)
)

;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n

(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

;;----------------------------------------------------------------------;;

(vl-load-com)
(princ
(strcat
"\n:: HeatGrid.lsp | Version 1.0 | © Lee Mac "
(menucmd "m=$(edtime,$(getvar,DATE),YYYY)")
" http://www.lee-mac.com ::"
"\n:: Type \"hd\" to Invoke ::"
)
)
(princ)
(c:hd)
;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;

Lee Mac Convert All Attribute Definitions to Text in one click


;;; Lee Mac Convert All Attribute Definitions to Text in one click
;;; Modified by Igal Averbuh 2016 (added option for all attributes)

(defun c:ADT ( / ss )
;; © Lee Mac ~ 01.06.10
(vl-load-com)

(if (setq ss (ssget "A" '((0 . "ATTDEF"))))
(
(lambda ( i / e o )
(while (setq e (ssname ss (setq i (1+ i))))
(if
(
(if (and (vlax-property-available-p
(setq o (vlax-ename->vla-object e)) 'MTextAttribute)
(eq :vlax-true (vla-get-MTextAttribute o)))

MAttDef2MText AttDef2Text
)
(entget e)
)
(entdel e)
)
)
)
-1
)
)
(princ)
)

(defun AttDef2Text ( eLst / dx74 dx2 )
;; © Lee Mac ~ 01.06.10

(setq dx74 (cdr (assoc 74 eLst)) dx2 (cdr (assoc 2 eLst)))

(entmake
(append '( (0 . "TEXT") ) (RemovePairs '(0 100 1 2 3 73 74 70 280) eLst)
(list
(cons 73 dx74)
(cons 1 dx2)
)
)
)
)

(defun MAttDef2MText ( eLst )
;; © Lee Mac ~ 01.06.10

(entmake
(append '( (0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText") )
(RemoveFirstPairs '(40 50 41 7 71 72 71 72 73 10 11 11 210)
(RemovePairs '(-1 102 330 360 5 0 100 101 1 2 3 42 43 51 74 70 280) eLst)
)
(list (cons 1 (cdr (assoc 2 eLst))))
)
)
)

(defun RemoveFirstPairs ( pairs lst )
;; © Lee Mac

(defun foo ( pair lst )
(if lst
(if (eq pair (caar lst))
(cdr lst)
(cons (car lst) (foo pair (cdr lst)))
)
)
)

(foreach pair pairs
(setq lst (foo pair lst))
)
lst
)

(defun RemovePairs ( pairs lst )
;; © Lee Mac
(vl-remove-if
(function
(lambda ( pair )
(vl-position (car pair) pairs)
)
)
lst
)
)
(c:adt)

Lee Mac Convert Attribute Definition to Text


;;; Lee Mac Convert Attribute Definition to Text

(defun c:ADT ( / ss )
;; © Lee Mac ~ 01.06.10
(vl-load-com)

(if (setq ss (ssget "_:L" '((0 . "ATTDEF"))))
(
(lambda ( i / e o )
(while (setq e (ssname ss (setq i (1+ i))))
(if
(
(if (and (vlax-property-available-p
(setq o (vlax-ename->vla-object e)) 'MTextAttribute)
(eq :vlax-true (vla-get-MTextAttribute o)))

MAttDef2MText AttDef2Text
)
(entget e)
)
(entdel e)
)
)
)
-1
)
)
(princ)
)

(defun AttDef2Text ( eLst / dx74 dx2 )
;; © Lee Mac ~ 01.06.10

(setq dx74 (cdr (assoc 74 eLst)) dx2 (cdr (assoc 2 eLst)))

(entmake
(append '( (0 . "TEXT") ) (RemovePairs '(0 100 1 2 3 73 74 70 280) eLst)
(list
(cons 73 dx74)
(cons 1 dx2)
)
)
)
)

(defun MAttDef2MText ( eLst )
;; © Lee Mac ~ 01.06.10

(entmake
(append '( (0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText") )
(RemoveFirstPairs '(40 50 41 7 71 72 71 72 73 10 11 11 210)
(RemovePairs '(-1 102 330 360 5 0 100 101 1 2 3 42 43 51 74 70 280) eLst)
)
(list (cons 1 (cdr (assoc 2 eLst))))
)
)
)

(defun RemoveFirstPairs ( pairs lst )
;; © Lee Mac

(defun foo ( pair lst )
(if lst
(if (eq pair (caar lst))
(cdr lst)
(cons (car lst) (foo pair (cdr lst)))
)
)
)

(foreach pair pairs
(setq lst (foo pair lst))
)
lst
)

(defun RemovePairs ( pairs lst )
;; © Lee Mac
(vl-remove-if
(function
(lambda ( pair )
(vl-position (car pair) pairs)
)
)
lst
)
)
(c:adt)

Count selected objects length by layer and put it in table form into a drawing


;Count selected objects length by layer and put it in table form into a drawing
;Stefan M. 22.09.2016
(defun C:LAY ( / *error* acdoc ss p i e a d l s h dz) (vl-load-com)
(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
dz (getvar 'dimzin))
(vla-startundomark acdoc)
(setvar 'dimzin 1)

(defun *error* (msg)
(and
msg
(not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(setvar 'dimzin dz)
(if
(= 8 (logand (getvar 'undoctl) 8))
(vla-endundomark acdoc)
)
(princ)
)

(if
(and
(setq ss (ssget ":L" '((0 . "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE,HATCH"))))
(setq p (getpoint "\nTable scale depend on annotation scale.\nSpecify table insert point: "))
)
(progn
(repeat
(setq i (sslength ss))
(setq e (vlax-ename->vla-object (ssname ss (setq i (1- i))))
a (vla-get-layer e)
)
(if
(setq h (eq (vla-get-objectname e) "AcDbHatch"))
(setq s (vla-get-area e))
(setq d (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))
)
(if
(setq o (assoc a l))
(if h
(setq l (subst (list a (cadr o) (+ (caddr o) s)) o l))
(setq l (subst (list a (+ (cadr o) d) (caddr o)) o l))
)
(if h
(setq l (cons (list a 0.0 s) l))
(setq l (cons (list a d 0.0) l))
)
)
)
(setq l (vl-sort l '(lambda (a b) (< (car a) (car b)))))
(insert_table l p)
)
)
(*error* nil)
(princ)
)

(defun insert_table (lst pct / tab row col ht i n space )
(setq space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
ht (/ 2.5 (cond ((getvar 'cannoscalevalue)) (1.0)))
pct (trans pct 1 0)
n (trans '(1 0 0) 1 0 T)
tab (setq tab (vla-addtable space (vlax-3d-point pct) (+ 2 (length lst)) (length (car lst)) (* 2.5 ht) ht))
)
(vlax-put tab 'direction n)

(mapcar
(function
(lambda (rowType)
(vla-SetTextStyle tab rowType (getvar 'textstyle))
(vla-SetTextHeight tab rowType ht)
)
)
'(2 4 1)
)

(vla-put-HorzCellMargin tab (* 0.14 ht))
(vla-put-VertCellMargin tab (* 0.14 ht))

(setq lst (cons '("Layer" "Length") lst))

(setq i 0)
(foreach col (apply 'mapcar (cons 'list lst))
(vla-SetColumnWidth tab i
(apply
'max
(mapcar
'(lambda (x)
((lambda (txb) (+ (abs (- (caadr txb) (caar txb))) (* 2.0 ht)))
(textbox
(list
(cons 1
(cond
((eq (type x) 'STR) x)
((eq (type x) 'INT) (itoa x))
((eq (type x) 'REAL) (rtos x))
)
)
(cons 7 (getvar 'textstyle))
(cons 40 ht))
)
)
)
col
)
)
)
(setq i (1+ i))
)

(setq lst (cons '("TITLE") lst))

(setq row 0)
(foreach r lst
(setq col 0)
(foreach c r
(if
(not (eq c 0))
(progn
(vla-SetText tab row col c)
(vla-SetCellDataType
tab row col
(cdr (assoc (type c) '((STR . 4) (REAL . 2) (INT . 1))))
acUnitless
)
(vla-setCellAlignment tab row col acMiddleCenter)
)
)
(setq col (1+ col))
)
(vla-SetRowHeight tab row (* 1.6 ht))
(setq row (1+ row))
)
)
(c:lay)

Rename selected blocks (add suffix) Written by Tharwat Al Shoufi


;;; Rename selected blocks (add suffix) Written by Tharwat Al Shoufi

(defun c:RSS (/ Blocks *error* cm r ss int sn sfx kw bks nam)
(vl-load-com)
;;; Tharwat 31. Oct. 2012 ;;;
;;; Rename selected or All Blocks as User's inputs ;;;
(or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
(setq Blocks (vla-get-blocks acdoc))
(setq cm (getvar 'cmdecho))
(defun *error* (x)
(if cm
(setvar 'cmdecho cm)
)
(vla-EndUndoMark acdoc)
(princ "\n")
(princ "\n *Cancel*:")
)
(if (and (not (eq (setq sfx (getstring t "\n Specify Suffix :")) ""))
(setq r (snvalid sfx))
(progn (initget "Selected All")
(setq kw (cond ((getkword "\n Rename [Selected . All] Blocks :"))
("Selected")
)
)
)
)
(if (eq kw "All")
(progn (vla-StartUndoMark acdoc)
(vlax-for x Blocks (vl-catch-all-apply 'vla-put-name (list x (strcat (vla-get-name x) sfx))))
(vla-EndUndoMark acdoc)
)
(if (setq ss (ssget "_:L" '((0 . "INSERT"))))
(progn (vla-StartUndoMark acdoc)
(setvar 'cmdecho 0)
(repeat (setq int (sslength ss))
(setq sn (ssname ss (setq int (1- int))))
(setq nam (cdr (assoc 2 (entget sn))))
(if (not (member nam bks))
(progn (vl-cmdf "_.-rename" "B" nam (setq nam (strcat nam sfx))) (setq bks (cons nam bks)))
)
)
(vla-EndUndoMark acdoc)
(setvar 'cmdecho cm)
)
)
)
(cond ((not sfx) (princ "\n Cancelled by user "))
((not r) (princ "\n Not Valid Block name "))
(t (princ "\n Cancelled by user "))
)
)
; (princ "\n Written by Tharwat Al Shoufi")
(princ)
)
(c:rss)

Rename selected blocks (add prefix) Written by Tharwat Al Shoufi


;;; Rename selected blocks (add prefix) Written by Tharwat Al Shoufi

(defun c:RSB (/ Blocks *error* cm r ss int sn sfx kw bks nam)
(vl-load-com)
;;; Tharwat 31. Oct. 2012 ;;;
;;; Rename selected or All Blocks as User's inputs ;;;
(or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
(setq Blocks (vla-get-blocks acdoc))
(setq cm (getvar 'cmdecho))
(defun *error* (x)
(if cm
(setvar 'cmdecho cm)
)
(vla-EndUndoMark acdoc)
(princ "\n")
(princ "\n *Cancel*:")
)
(if (and (not (eq (setq sfx (getstring t "\n Specify Prefix :")) ""))
(setq r (snvalid sfx))
(progn (initget "Selected All")
(setq kw (cond ((getkword "\n Rename [Selected . All] Blocks :"))
("Selected")
)
)
)
)
(if (eq kw "All")
(progn (vla-StartUndoMark acdoc)
(vlax-for x Blocks (vl-catch-all-apply 'vla-put-name (list x (strcat sfx (vla-get-name x)))))
(vla-EndUndoMark acdoc)
)
(if (setq ss (ssget "_:L" '((0 . "INSERT"))))
(progn (vla-StartUndoMark acdoc)
(setvar 'cmdecho 0)
(repeat (setq int (sslength ss))
(setq sn (ssname ss (setq int (1- int))))
(setq nam (cdr (assoc 2 (entget sn))))
(if (not (member nam bks))
(progn (vl-cmdf "_.-rename" "B" nam (setq nam (strcat sfx nam))) (setq bks (cons nam bks)))
)
)
(vla-EndUndoMark acdoc)
(setvar 'cmdecho cm)
)
)
)
(cond ((not sfx) (princ "\n Cancelled by user "))
((not r) (princ "\n Not Valid Block name "))
(t (princ "\n Cancelled by user "))
)
)
; (princ "\n Written by Tharwat Al Shoufi")
(princ)
)
(c:rsb)

Draw Length of multi Lines, Arcs, Circles and Ellipses as Masked Mtext


;;; Draw length of multi Lines, Arcs, Circles and Ellipses as Masked Mtext
;;; Saved from here: http://www.cadtutor.net/forum/showthread.php?56656-Lisp-help-Selecting-multi-lines-and-labeling-them/page2

(defun c:lm(/ aDoc cTxt eLen ePar iAng iDr lPnt lSet oldSize sPar tWid lCol
cLay nTxt Precision Suffix BackMask Layer Color)

; *****************************************************************************
; ADJUSTMENTS ;
; (Modify it to adjust for your own requirements) ;
; *****************************************************************************

(setq Precision 1) ; - precision of measurement (digits after decimal point)

(setq Suffix "m") ; - Suffix after measirement for ex. "'" or "" for none

(setq BackMask 1.0) ; - Background mask borders from 1.0 to 10.0
; or nil for none. Reocomended value 1.0.
; !!! nil for versions ealer AutoCAD 2005 !!!

(setq Layer "0-Length-Calculation") ; - layer of markers or nil for current layer

(setq Color 1) ; - color of layer for ex. 1 (Red)

; ******************************* END ADJUSTMENTS *****************************

(vl-load-com)

(defun Add_Masked_MText(Str Pt Hei Wid wiF Ang Mask
/ oOsn cLay cTxt actSp nTxt
oDxf nDxf mPt xPt aDoc aSp lFlg)

; (Add_Masked_MText )

(setq oOsn(getvar "OSMODE")
aDoc(vla-get-ActiveDocument
(vlax-get-acad-object))
cLay (vla-get-ActiveLayer aDoc)
aSp(vla-get-ActiveSpace aDoc)
); end setq
(if(= 1 aSp)
(setq aSp(vla-get-ModelSpace aDoc))
(setq aSp(vla-get-PaperSpace aDoc))
); end if
(if(= :vlax-true(vla-get-Lock cLay))
(progn
(vla-put-Lock cLay :vlax-false)
(setq lFlg T)
); end progn
); end if
(if(= 1.0 wiF)
(setq cTxt(strcat "\\pxqc;" Str))
(setq cTxt(strcat "\\pxqc;{\\W" (rtos wiF) ";" Str "}"))
); end if
(setq nTxt(vla-AddMText aSp
(vlax-3D-point '(0.0 0.0 0.0)) 1.0 cTxt))
(vla-put-Height nTxt Hei)
(vla-put-Width nTxt(+ Wid(/ Hei 2)))
(if Mask
(progn
(vla-put-BackgroundFill nTxt -1)
(setq oDxf(entget(vlax-vla-object->ename nTxt))
nDxf(subst (cons 45 Mask)(assoc 45 oDxf)oDxf)
); end setq
(entmod nDxf)
); end progn
); end if
(vla-getBoundingBox nTxt 'mPt 'xPt)
(setq mPt(vlax-safearray->list mPt)
xPt(vlax-safearray->list xPt)
mPt(vlax-3d-point
(list(+(car mPt)(/(-(car xPt)(car mPt))2))
(+(cadr mPt)(/(-(cadr xPt)(cadr mPt))2))
0.0))
); end setq
(vla-Move nTxt mPt(vlax-3D-point Pt))
(if(and(> Ang 0)(<= Ang pi))
(vla-Rotate nTxt(vlax-3D-point Pt)(- Ang(/ pi 2)))
(vla-Rotate nTxt(vlax-3D-point Pt)(+ Ang(/ pi 2)))
); end if
(if lFlg
(vla-put-Lock cLay :vlax-true)
); end if
nTxt
); end of Add_Masked_MText

(if(not lab:Size)(setq lab:Size(getvar "TEXTSIZE")))
(setq oldSize lab:Size
lab:Size
(getreal
(strcat "\nText size : ")))
(if(null lab:Size)(setq lab:Size oldSize))
(princ "\n<<>> ")
(if(setq lSet(ssget '((0 . "*LINE,ARC,ELLIPSE,CIRCLE"))))
(progn
(setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object))
lCol(vla-get-Layers aDoc)
); end setq
(vla-StartUndoMark aDoc)
(if Layer
(if(vl-catch-all-error-p
(vl-catch-all-apply
'vla-Item(list lCol Layer)))
(progn
(setq cLay(vla-Add lCol Layer))
(vla-put-Color cLay Color)
); end progn
); end if
); end if
(foreach l(vl-remove-if 'listp(mapcar 'cadr(ssnamex lSet)))
(setq sPar(vlax-curve-getStartParam l)
ePar(vlax-curve-getEndParam l)
eLen(-(vlax-curve-getDistAtParam l ePar)
(vlax-curve-getDistAtParam l sPar))
lPnt(vlax-curve-getPointAtDist l(/ eLen 2))
iDr(vlax-curve-getFirstDeriv l
(vlax-curve-getParamAtPoint l lPnt))
iAng(- pi
(atan
(/(car iDr)
(if(= 0.0(cadr iDr))(* 2 pi)(cadr iDr)))))
cTxt(strcat(rtos eLen 2 Precision)Suffix)
tWid(caadr
(textbox
(list(cons 1 cTxt)
(cons 40 lab:Size)(cons 41 0.8))))
); end setq
(setq nTxt(Add_Masked_MText cTxt lPnt lab:Size (+ tWid(/ lab:Size 3)) 0.8 iAng BackMask))
(if Layer
(vla-put-Layer nTxt Layer)
); end if
(vla-EndUndoMark aDoc)
); end foreach
); end progn
(princ "\n Nothing selected ")
); end if
(princ)
); end of c:lmark
(c:lm)