Convert straight to arc segments in multiple polylines at once


;;; Convert straight to arc segments in multiple polylines at once
;;; Created by Marko Ribar
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/convert-polyline-line-segments-to-arc-segments/m-p/5814922/highlight/true#M335051

(defun c:p2a
(/ massoclst nthmassocsubst v^v unit _ilp d doc lw enx gr enxb p p1 p2 p3 b i n)
(vl-load-com)
(defun massoclst (key lst)
(if (assoc key lst)
(cons (assoc key lst) (massoclst key (cdr (member (assoc key lst) lst))))
)
)
(defun nthmassocsubst (n key value lst / k slst p j plst m tst pslst)
(setq k (length (setq slst (member (assoc key lst) lst))))
(setq p (- (length lst) k))
(setq j -1)
(repeat p (setq plst (cons (nth (setq j (1+ j)) lst) plst)))
(setq plst (reverse plst))
(setq j -1)
(setq m -1)
(repeat k
(setq j (1+ j))
(if (equal (assoc key (member (nth j slst) slst)) (nth j slst) 1e-6)
(setq m (1+ m))
)
(if (and (not tst) (= n m))
(setq pslst (cons (cons key value) pslst)
tst t
)
(setq pslst (cons (nth j slst) pslst))
)
)
(setq pslst (reverse pslst))
(append plst pslst)
)
(defun v^v (u v)
(mapcar
'(lambda (s1 s2 a b) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u)))))
'(+ - +)
'(- + -)
'(1 0 0)
'(2 2 1)
)
)
(defun unit (v) (mapcar '(lambda (x) (/ x (distance '(0.0 0.0 0.0) v))) v))
(defun _ilp (p1 p2 o nor / p1p p2p op tp pp p)
(if (not (equal (v^v nor (unit (mapcar '- p2 p1))) '(0.0 0.0 0.0) 1e-7))
(progn
(setq p1p (trans p1 0 (v^v nor (unit (mapcar '- p2 p1))))
p2p (trans p2 0 (v^v nor (unit (mapcar '- p2 p1))))
op (trans o 0 (v^v nor (unit (mapcar '- p2 p1))))
op (list (car op) (cadr op) (caddr p1p))
tp (polar op
(+ (* 0.5 pi)
(angle '(0.0 0.0 0.0) (trans nor 0 (v^v nor (unit (mapcar '- p2 p1)))))
)
1.0
)
)
(if (inters p1p p2p op tp nil)
(progn (setq p (trans (inters p1p p2p op tp nil) (v^v nor (unit (mapcar '- p2 p1))) 0)) p)
nil
)
)
(progn (setq pp (list (car (trans p1 0 nor)) (cadr (trans p1 0 nor)) (caddr (trans o 0 nor))))
(setq p (trans pp nor 0))
p
)
)
)
(or doc (setq doc (vla-get-activedocument (vlax-get-acad-object))))
(vla-startundomark doc)
;; RJP - added multiple selection 04.02.2018
(if (setq s (ssget ":L" '((0 . "lwpolyline"))))
(foreach lw (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
(setq i (fix (vlax-curve-getparamatpoint
lw
(vlax-curve-getclosestpointtoprojection
lw
(trans (setq p (vlax-curve-getstartpoint lw)) 1 0)
'(0.0 0.0 1.0)
)
) ;_ vlax-curve-getParamAtPoint
) ;_ fix
p1 (vlax-curve-getpointatparam lw i)
p3 (vlax-curve-getpointatparam lw (1+ i))
)
(setq enxb (massoclst 42 (setq enx (entget lw))))
(setq p2 (_ilp (trans p 1 0)
(mapcar '+ (trans p 1 0) '(0.0 0.0 1.0))
p1
(cdr (assoc 210 (entget lw)))
)
)
(setq
b ((lambda (a) (/ (sin a) (cos a)))
(/ (- (angle (trans p2 0 lw) (trans p3 0 lw)) (angle (trans p1 0 lw) (trans p2 0 lw)))
2.0
)
)
)
(setq n -1)
(foreach dxf42 enxb
(setq n (1+ n))
(if (= n i)
(setq enx (nthmassocsubst n 42 b enx))
(setq enx (nthmassocsubst n 42 (+ (cdr dxf42) b) enx))
)
)
(entupd (cdr (assoc -1 (entmod enx))))
)
(prompt "\n Nothing selected or picked object not a LWPOLYLINE ")
)
(vla-endundomark doc)
(princ)
)
(c:p2a)

Advertisements

Dimension Sum Report as txt file with text string in format A+B+C+.. = Sum


; Dimmension Sum Report as txt file with text string in format A+B+C+.. = Sum
; Modified by Igal Averbuh 2018 and
; Deeply improved by pbejse
; Saved from: https://forums.autodesk.com/t5/user/viewprofilepage/user-id/564264
; Based on mfuccaro@hotmail.com routine with Enhancements by CAD Studio, 2012 and Tharwat routine
; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/routine-to-sum-multiples-dimensions/td-p/5268327

(setq _dimexpdelimiter "+") ; set to ";" for CSY/DEU...

(defun C:Ds ( / string_forExport valuetoadd s tx fn i d dl m file)

(if (setq iz 0.
string_forExport nil
s (ssget (list '(0 . "DIMENSION"))))
((lambda (% / sn)
(while (setq sn (ssname s (setq % (1+ %))))
(setq sn (vlax-ename->vla-object sn))
(setq valuetoadd
(if (numberp (setq to (read (vla-get-TextOverride sn))))
to (vla-get-measurement sn)))
(setq string_forExport (cons (strcat _dimexpdelimiter (rtos valuetoadd 2 1))
string_forExport))
(setq iz (+ valuetoadd iz))
)
)
-1
)
)
(if (> iz 0.)
(progn
(princ (strcat "\nTotal: " (rtos iz 2 1)))
(setq tx nil
fn (strcat (getvar "dwgprefix") "Dimension Export Report.txt"))
(setq file (open fn "a")) ; append
(write-line "" file)
(princ (strcat (substr (apply 'strcat string_forExport) 2) " = " (rtos iz 2 1)) file)
(close file)
(princ (strcat "\n" (itoa (length tx)) " dimensions written to " fn))
(startapp "notepad.exe" fn)
)
)
(princ)
)
(c:ds)

;|«Visual LISP© Format Options»
(72 6 40 0 nil "end of " 60 6 0 0 nil nil T nil T)
;*** DO NOT add text below the comment! ***|;

Draw Quadratic Dynamic Zig-Zag Polyline


;; Draw Quadratic Dynamic Zig-Zag Polyline - Created by Lee Mac
;; Saved from: http://www.cadtutor.net/forum/showthread.php?74752-Lisp-for-drawing-polylines
;; Modified by Igal Averbuh 2018

(defun c:dzg ( / a d g i l p q r x y )
(setq x (getdist (strcat "\nSpecify Weld Length: "))
y (getdist (strcat "\nSpecify Weld Width: "))
i (/ pi 2.0)
)

(while

(if (setq p (getpoint "\nSpecify 1st or Next Point: "))
(progn
(princ "\nSpecify 2nd Point [+/-] : ")
(while
(progn
(setq g (grread t 15 0)
q (cadr g)
g (car g)
)
(cond
( (member g '(3 5))
(redraw)
(setq a (angle p q)
d (distance p q)
i (abs i)
r p
)
(repeat (fix (/ d x))
(grdraw r (setq r (polar r a x)) 1 1)
(grdraw r (setq r (polar r (+ a (setq i (- i))) y)) 1 1)
)
(if (not (equal 0.0 (rem d x) 1e-8))
(grdraw r (polar r a (rem d x)) 1 1)
)
(= 5 g)
)
( (= 2 g)
(cond
( (member q '(43 61))
(setq x (1+ x))
)
( (member q '(45 95))
(setq x (max (1- x) 1))
)
)
)
)
)
)
(if (= 3 g)
(progn
(setq i (abs i)
p (trans p 1 0)
q (trans q 1 0)
a (angle p q)
)
(repeat (fix (/ d x))
(setq l (cons (cons 10 p) l)
l (cons (cons 10 (setq p (polar p a x))) l)
l (cons (cons 10 (setq p (polar p (+ a (setq i (- i))) y))) l)
)
)
(if (not (equal 0.0 (rem d x) 1e-8))
(setq l (cons (cons 10 (polar p a (rem d x))) l))
)
(entmake
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length l))
'(70 . 0)
)
(reverse l)
)
)
)
)
)
(redraw)
)

)

(princ)
)
(c:dzg)

Draw Triangle dynamic Zig-Zag polyline


;; Draw Triangle dynamic Zig-Zag polyline. Created by Marko Ribar
;; Saved from: http://www.cadtutor.net/forum/showthread.php?74752-Lisp-for-drawing-polylines
;; Based on Lee Mac functions
;; Modified by Igal Averbuh 2018

;; Object Snap for grread: Snap Function - Lee Mac
;; Returns: [fun] A function requiring two arguments:
;; p - [lst] UCS Point to be snapped
;; o - [int] Object Snap bit code
;; The returned function returns either the snapped point (displaying an appropriate snap symbol)
;; or the supplied point if the snap failed for the given Object Snap bit code.

(defun LM:grsnap:snapfunction ( )
(eval
(list 'lambda '( p o / q )
(list 'if '(zerop (logand 16384 o))
(list 'if
'(setq q
(cdar
(vl-sort
(vl-remove-if 'null
(mapcar
(function
(lambda ( a / b )
(if (and (= (car a) (logand (car a) o)) (setq b (osnap p (cdr a))))
(list (distance p b) b (car a))
)
)
)
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(2048 . "_app")
(8192 . "_par")
)
)
)
'(lambda ( a b ) (ACI
(if (= 1 (getvar 'cvport))
(atoi (cond ((getenv "Layout AutoSnap Color")) ("117761")))
(atoi (cond ((getenv "Model AutoSnap Color")) ("104193")))
)
)
)
)
)
'(cond ((car q)) (p))
)
)
)

;; Object Snap for grread: Display Snap - Lee Mac
;; pnt - [lst] UCS point at which to display the symbol
;; lst - [lst] grvecs vector list
;; col - [int] ACI colour for displayed symbol
;; Returns nil

(defun LM:grsnap:displaysnap ( pnt lst col / scl )
(setq scl (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
pnt (trans pnt 1 2)
)
(grvecs (cons col lst)
(list
(list scl 0.0 0.0 (car pnt))
(list 0.0 scl 0.0 (cadr pnt))
(list 0.0 0.0 scl 0.0)
'(0.0 0.0 0.0 1.0)
)
)
)

;; Object Snap for grread: Snap Symbols - Lee Mac
;; p - [int] Size of snap symbol in pixels
;; Returns: [lst] List of vector lists describing each Object Snap symbol

(defun LM:grsnap:snapsymbols ( p / -p -q -r a c i l q r )
(setq -p (- p) q (1+ p)
-q (- q) r (+ 2 p)
-r (- r) i (/ pi 6.0)
a 0.0
)
(repeat 12
(setq l (cons (list (* r (cos a)) (* r (sin a))) l)
a (- a i)
)
)
(setq c (apply 'append (mapcar 'list (cons (last l) l) l)))
(list
(list 1
(list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
(list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
)
(list 2
(list -r -q) (list 0 r) (list 0 r) (list r -q)
(list -p -p) (list p -p) (list p -p) (list 0 p) (list 0 p) (list -p -p)
(list -q -q) (list q -q) (list q -q) (list 0 q) (list 0 q) (list -q -q)
)
(cons 4 c)
(vl-list* 8 (list -r -r) (list r r) (list r -r) (list -r r) c)
(list 16
(list p 0) (list 0 p) (list 0 p) (list -p 0) (list -p 0) (list 0 -p) (list 0 -p) (list p 0)
(list q 0) (list 0 q) (list 0 q) (list -q 0) (list -q 0) (list 0 -q) (list 0 -q) (list q 0)
(list r 0) (list 0 r) (list 0 r) (list -r 0) (list -r 0) (list 0 -r) (list 0 -r) (list r 0)
)
(list 32
(list r r) (list -r -r) (list r q) (list -q -r) (list q r) (list -r -q)
(list -r r) (list r -r) (list -q r) (list r -q) (list -r q) (list q -r)
)
(list 64
'( 0 1) (list 0 p) (list 0 p) (list -p p) (list -p p) (list -p -1) (list -p -1) '( 0 -1)
'( 0 -1) (list 0 -p) (list 0 -p) (list p -p) (list p -p) (list p 1) (list p 1) '( 0 1)
'( 1 2) (list 1 q) (list 1 q) (list -q q) (list -q q) (list -q -2) (list -q -2) '(-1 -2)
'(-1 -2) (list -1 -q) (list -1 -q) (list q -q) (list q -q) (list q 2) (list q 2) '( 1 2)
)
(list 128
(list (1+ -p) 0) '(0 0) '(0 0) (list 0 (1+ -p))
(list (1+ -p) 1) '(1 1) '(1 1) (list 1 (1+ -p))
(list -p q) (list -p -p) (list -p -p) (list q -p)
(list -q q) (list -q -q) (list -q -q) (list q -q)
)
(vl-list* 256 (list -r r) (list r r) (list -r (1+ r)) (list r (1+ r)) c)
(list 512
(list -p -p) (list p -p) (list -p p) (list p p) (list -q -q) (list q -q)
(list q -q) (list -q q) (list -q q) (list q q) (list q q) (list -q -q)
)
(list 2048
(list -p -p) (list p p) (list -p p) (list p -p)
(list (+ p 05) -p) (list (+ p 06) -p) (list (+ p 05) -q) (list (+ p 06) -q)
(list (+ p 09) -p) (list (+ p 10) -p) (list (+ p 09) -q) (list (+ p 10) -q)
(list (+ p 13) -p) (list (+ p 14) -p) (list (+ p 13) -q) (list (+ p 14) -q)
(list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
(list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
)
(list 8192 (list r 1) (list -r -q) (list r 0) (list -r -r) (list r q) (list -r -1) (list r r) (list -r 0))
)
)

;; Object Snap for grread: Parse Point - Lee Mac
;; bpt - [lst] Basepoint for relative point input, e.g. @5,5
;; str - [str] String representing point input
;; Returns: [lst] Point represented by the given string, else nil

(defun LM:grsnap:parsepoint ( bpt str / str->lst lst )

(defun str->lst ( str / pos )
(if (setq pos (vl-string-position 44 str))
(cons (substr str 1 pos) (str->lst (substr str (+ pos 2))))
(list str)
)
)

(if (wcmatch str "`@*")
(setq str (substr str 2))
(setq bpt '(0.0 0.0 0.0))
)

(if
(and
(setq lst (mapcar 'distof (str->lst str)))
(vl-every 'numberp lst)
( ACI - Lee Mac
;; Args: c - [int] OLE Colour

(defun LM:OLE->ACI ( c )
(apply 'LM:RGB->ACI (LM:OLE->RGB c))
)

;; OLE -> RGB - Lee Mac
;; Args: c - [int] OLE Colour

(defun LM:OLE->RGB ( c )
(mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)

;; RGB -> ACI - Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values

(defun LM:RGB->ACI ( r g b / c o )
(if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
(vlax-release-object o)
(if (vl-catch-all-error-p c)
(prompt (strcat "\nError: " (vl-catch-all-error-message c)))
c
)
)
)
)

;; Application Object - Lee Mac
;; Returns the VLA Application Object

(defun LM:acapp nil
(eval (list 'defun 'LM:acapp 'nil (vlax-get-acad-object)))
(LM:acapp)
)

(vl-load-com) (princ)

;; Dynamic Zig-Zag - M.R.

(defun c:dtz ( / unique osf osm a d gr g i l p q r x )
(defun unique ( l )
(if l (cons (car l) (vl-remove (car l) (unique (cdr l)))))
)
(defun collinear-p ( p1 p p2 )
(equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-8)
)
(setq osf (LM:grsnap:snapfunction) ;; Define optimised Object Snap function
osm (getvar 'osmode) ;; Retrieve active Object Snap modes
)
(setq x (getdist (strcat "\nSpecify Tryangle Edge Length: "))
i (/ pi 4.0)
)
(while
(if (setq p (getpoint "\nSpecify 1st or Next Point: "))
(progn
(princ "\nSpecify 2nd Point [+/-] : ")
(while
(progn
(setq gr (grread t 15 0)
g (car gr)
)
(cond
( (member g '(3 5))
(redraw)
(setq a (angle p (setq q (osf (cadr gr) osm)))
d (distance p q)
i (abs i)
r p
)
(repeat (fix (/ d x))
(grdraw r (setq r (polar r (+ a i) (/ x (sqrt 2.0)))) 1 1)
(grdraw r (setq r (polar r (+ a (setq i (- i))) (/ x (sqrt 2.0)))) 1 1)
)
(if (not (equal 0.0 (rem d x) 1e-8))
(grdraw r (polar r a (rem d x)) 1 1)
)
(= 5 g)
)
( (= 2 g)
(cond
( (member q '(43 61))
(setq x (1+ x))
)
( (member q '(45 95))
(setq x (max (1- x) 1))
)
)
)
)
)
)
(if (= 3 g)
(progn
(setq i (abs i)
p (trans p 1 0)
q (trans q 1 0)
a (angle p q)
)
(repeat (fix (/ d x))
(setq l (cons (cons 10 p) l)
l (cons (cons 10 (setq p (polar p (+ a i) (/ x (sqrt 2.0))))) l)
l (cons (cons 10 (setq p (polar p (+ a (setq i (- i))) (/ x (sqrt 2.0))))) l)
)
)
(if (not (equal 0.0 (rem d x) 1e-8))
(setq l (cons (cons 10 (polar p a (rem d x))) l))
)
(setq l (unique l))
(mapcar '(lambda ( a b c ) (if (collinear-p (cdr a) (cdr b) (cdr c)) (setq l (vl-remove b l)))) l (cdr l) (cddr l))
(entmake
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length l))
'(70 . 0)
)
(reverse l)
)
)
)
)
)
(redraw)

)
)
(princ)
)
(c:dtz)

Rotate North Block to Viewport WCS


;;; Rotate North Block to Viewport WCS
;;; Created by: Lee Mac
;;; Saved from: https://www.theswamp.org/index.php?topic=54008.0

(defun c:nar ( / ent obj sel )
(if (= 1 (getvar 'cvport))
(progn
(while
(progn (setvar 'errno 0) (princ "\nSelect a viewport: ")
(not
(or (setq sel (ssget "_+.:E:S" '((0 . "VIEWPORT"))))
(= 52 (getvar 'errno))
)
)
)
(princ "\nMissed, try again.")
)
(if sel
(while
(progn
(setvar 'errno 0)
(setq ent (car (entsel "\nSelect north arrow: ")))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (null ent) nil)
( (/= "INSERT" (cdr (assoc 0 (entget ent))))
(princ "\nThe selected object is not a block.")
)
( (not (vlax-write-enabled-p (setq obj (vlax-ename->vla-object ent))))
(princ "\nThe selected block is on a locked layer.")
)
( (vla-put-rotation obj (cdr (assoc 51 (entget (ssname sel 0))))))
)
)
)
)
)
(princ "\nCommand only available in Paperspace.")
)
(princ)
)
(vl-load-com) (princ)
(c:nar)

Isolate Blocks by Layer


(vl-load-com)

(defun c:LIO ( / _pac :GetBlocksLayersSS ss new temp en i i2 lst lays)

;; Based on routine written by Alan J. Thompson, 03.31.11
;; http://www.cadtutor.net/forum/showthread.php?57864-How-to-select-all-objects-enclosed-in-a-poly-line&p=392378&viewfull=1#post392378
;; Modified by Igal Averbuh 2018 (added option to restore previous layer state after nested layer isolation)
(defun _pac (e / l v d lst)
(setq d (- (setq v (/ (setq l (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))) 100.))))
(while ( (cdr (assoc 62 (tblsearch "layer" (getvar 'clayer)))) 0)
(setvar 'clayer "0")
(setvar 'clayer (car lst)))

(command "expert" "0")
))
(princ)
;(alert "Use LUO to restore Current Layer State")
)
;(c:lio)

(defun c:LUO (/)
(if (layerstate-has "_LAYISOCUR_STATE")
(progn
(layerstate-restore "_LAYISOCUR_STATE")
(layerstate-delete "_LAYISOCUR_STATE")
)
(print "There's no layer state to restore.")
)
(princ)
)

Kent Cooper’s put Text indicating LENGTH(s) of selected object(s) at MIDPOINT(s) of these objects


;| LengthAtMidPoints.lsp [command name: LMP]
To put Text indicating LENGTH(s) of selected object(s) at MIDPOINT(s).
Draws Text in current Style and on current Layer.
Works with objects in any Coordinate System.
Kent Cooper, 27 February 2018
|;
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/line-length-typing-lisp/td-p/2119240
;;; Slightly Modified by Igal Averbuh 2018 (added option to set text height, also by 2 points on screen + creating new text style and new layer with ID data)

;UCS and Layer State with date,time stamp and user name. Upgrated by Igal Averbuh 2015

(defun C:ldate (/ ss1 count emax en ed blkn found
thedate thetime plotby)
;define function and declare variables as local

(setvar "HIGHLIGHT" 0)
;switch off highlight

(setvar "CMDECHO" 0)
;switch off command echo

(setq ss1 (ssget "X" '((0 . "INSERT")(66 . 1))))
;filter for all blocks with attributes

(if ss1
;if any are found

(progn
;do the following

(setq count 0
;set the counter to zero

emax (sslength ss1)
;get the number of blocks

);setq

(while (< count emax)
;while the counter is less than the
;number of blocks

(setq en (ssname ss1 count)
;get the entity name

ed (entget en)
;get the entity list

blkn (dxf 2 ed)
;get the block name

);setq

(if (= "STAMP")
;if the block name is "STAMP"

(setq count emax
;stop the loop

found T
;set the flag

);setq

(setq count (1+ count))
;if not increment the counter

);end if

);while & if

(if found
;if the flag is set

()
;erase the block

);if

);progn

);if

(setvar "ATTDIA" 0)
;switch off dialogue boxes

(setq thedate (today))
;calculate and format date

(setq thetime (time))
;calculate and format time

(setq plotby (getvar "LOGINNAME"))
;get the users name

(setq by (strcat "0Length Calculated by " plotby " " thedate " " thetime ))

(command "-layer" "n" by "")
(command "-layer" "s" by "")

()
;insert the block and fill in the attribute data

(setvar "ATTDIA" 1)
;switch the dialogues back on

(setvar "HIGHLIGHT" 1)
;switch Highlight On

(setvar "CMDECHO" 1)
;switch Cmdecho On

(princ)

);defun

;===============================================================
(defun dxf(code elist)

(cdr (assoc code elist))
;finds the association pair, strips 1st element

);defun
;===============================================================
(defun TODAY ( / d yr mo day)
(setq d (rtos (getvar "CDATE") 2 6)
yr (substr d 3 2)
mo (substr d 5 2)
day (substr d 7 2)
);setq
(strcat day "-" mo "-" yr)
);defun
;;;*-----------------------------------------------------------
(defun TIME ( / d hr m s)
(setq d (rtos (getvar "CDATE") 2 6)
hr (substr d 10 2)
m (substr d 12 2)
s (substr d 14 2)
);setq
(strcat hr "-" m "-" s)
);defun
;;;*------------------------------------------------------------
(princ)

(c:ldate)

(defun c:kent () ;; Create text style arial.ttf
(command "-style" "kent" "arial.ttf" "" "" "0" "" "")
)

(c:kent)

(vl-load-com)

(defun C:LMP ; = Length at Mid-Point
(/ *error* lmp-reset LMPss doc svnames svvals n path pathdata pathtype pathextr ucschanged lmp-pt len)

(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); if
(if ucschanged (command "_.ucs" "_prev"))
;; ^ don't go back unless routine reached UCS change but didn't change it back
(vla-endundomark doc)
(lmp-reset)
); defun - *error*

(defun lmp-reset ()
(mapcar 'setvar svnames svvals); reset
(princ)
); defun - lmp-reset

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

(prompt "\nTo mark Length(s) at object Midpoint(s),")
(if
(setq LMPss (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))))
(progn ; then
(vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
(setq
svnames '(osmode blipmode cmdecho)
svvals (mapcar 'getvar svnames)
); setq
(setvar 'cmdecho 0)
(repeat (setq n (sslength LMPss))
(setq
path (ssname LMPss (setq n (1- n)))
pathdata (entget path)
pathtype (cdr (assoc 0 pathdata))
pathtype
(if (wcmatch pathtype "POLYLINE")
(strcase (substr (cdr (assoc 100 (reverse pathdata))) 5)); then
;; ^ = entity type from second (assoc 100) without "AcDb" prefix; uses this because (assoc 0)
;; value is the same for 2D heavy & 3D Polylines; can set UCS to match former, but not latter
pathtype ; else - leave alone
); if and pathtype
pathextr (cdr (assoc 210 pathdata))
); setq
(if ; set UCS to match object only under certain circumstances
(or ; look at entity types other than 3D Polylines and 3D Splines
(and
(= pathtype "LINE")
(not ; unequal Z components at ends, in current CS
(equal
(caddr (trans (cdr (assoc 10 pathdata)) 0 1))
(caddr (trans (cdr (assoc 11 pathdata)) 0 1))
1e-12
); equal
); not
); and - Line UCS check
(and
(wcmatch pathtype "ARC,CIRCLE,ELLIPSE,LWPOLYLINE,2DPOLYLINE")
(not (equal (trans pathextr 0 1) '(0 0 1) 1e-6)); extrusion direction not = current CS
); and - A/C/E/LWP/2dP UCS check
(and
(= pathtype "SPLINE")
(if pathextr (not (equal (trans pathextr 0 1) '(0 0 1) 1e-12)))
;; ^ planar [2D] Splines have 210 value; non-planar [3D] do not
); and - Spline UCS check
); or - need to change UCS
(progn
(if (equal pathextr '(0 0 1) 1e-12)
(command "_.ucs" "_world"); then
(if (= pathtype "LINE") ; outer else -- set UCS to match object
(command "_.ucs" (vlax-curve-getStartPoint path) (vlax-curve-getEndPoint path) "")
; then -- sometimes UCS OB on Line does it with Line up Z axis
(command "_.ucs" "_new" "_object" path); else [other entity types]
); if
); if
(setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't get to it
); progn
); if - UCS match object
(mapcar 'setvar svnames '(0 0)); Osnap and blips off
(command
"_.text" "_justify" "_bc"
(trans
(setq lmp-pt ; insertion point
(vlax-curve-getPointAtDist ; midway along length
path
(/
(setq len (vlax-curve-getDistAtParam path (vlax-curve-getEndParam path))); overall length
2
); /
); getPointAtDist
); setq
0 1 ; WCS to current CS
)
); command ; leave in Text command
(if (member '(40 . 0.0) (entget (tblobjname "style" (getvar 'textstyle)))) (command ""))
; accept current-height default if non-fixed-height or non-annotative Style
(command ; continue
(angtos ; rotation -- local direction of path
(+
(angle
'(0 0 0)
(trans
(vlax-curve-getFirstDeriv
path
(vlax-curve-getParamAtPoint path lmp-pt)
); getFirstDeriv
0 1 T; WCS to current CS, as displacement
); trans
); angle
(if ; put text on outboard side of Arc/Circle/Ellipse/LWPline arc segment
(or
(wcmatch pathtype "ARC,CIRCLE,ELLIPSE")
(and
(= pathtype "LWPOLYLINE") ;;;;; what about "heavy" Polyline arc segment?
(> ; midway point on arc segment with CCW curvature?
(vla-getBulge (vlax-ename->vla-object path) (vlax-curve-getParamAtPoint path lmp-pt))
0.0
); >
); and
); or
pi 0 ; then = spin around, else = direction unaltered
); if
); +
(getvar 'aunits) 8
); angtos
(rtos len 2 1); text content
); command
(if ucschanged (progn (command "_.ucs" "_prev") (setq ucschanged nil)))
; eliminate UCS reset in *error* since routine did it already
); repeat
(lmp-reset)
(vla-endundomark doc)
); progn
); if
); defun - LMP

(prompt "Type LMP to mark the Lengths of selected objects at their Mid-Points.")
(c:lmp)

Copy Nested (xref) object in the exact same location on main drawing in a one click


;;; Copy Nested (Xref) object in the exact same location on main drawing in a one click
;;; Modified by Igal Averbuh 2018 (added loop option and set red colour of object transfered to main drawing)
;;; Inspired by patric_35 routine: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/copy-objects-from-xref/td-p/2552308

(defun c:nc(/ blo cod ent nom sel)

(and (setq sel (nentselp))
(= (type (setq blo (last (last sel)))) 'ENAME)
(/= (logand (cdr (assoc 70 (tblsearch "block" (setq nom (cdr (assoc 2 (entget blo))))))) 124) 0)
(setq ent (entget (car sel)))
(progn
(foreach cod '(-1 5 330)
(setq ent (vl-remove (assoc cod ent) ent))
)
(foreach cod '(6 8)
(and (assoc cod ent)
(eq (substr (cdr (assoc cod ent)) 1 (strlen nom)) nom)
(setq ent (subst (cons cod (substr (cdr (assoc cod ent)) (+ (strlen nom) 2))) (assoc cod ent) ent))
)
)
(entmake ent)
(setq obj (vlax-ename->vla-object (entlast)))
(vla-transformby obj (vlax-tmatrix (caddr sel)))
(setq lst (cons (list obj (vla-get-color obj)) lst))
(vla-put-color obj 1)
(vla-update obj)
)
)
(princ)
(c:nc)
)
;(c:nc)

Changes selected object layer to a true color (RGB) with dialog box


;;Changes selected object layer to a true color
;;of chose from a dialog
;; Created by: Jason Rhymes
;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/layer-color-to-true-color-color-books-by-picking-an-object-from/td-p/2431036
box
(defun c:slt (/ ent ent_data rgb str objlay)

(setq ent
(entsel)
)

(setq ent_data
(entget
(car ent)

)
)
(setq rgb

(TrueColor-split
(cdr (assoc
420

(acad_truecolordlg
'(420 .
16711680)

)
)
)
)
)

(setq str
(strcat
(rtos (car rgb) 2
0)
","
(rtos (cadr rgb) 2
0)
","
(rtos (caddr rgb) 2
0)
)
)
(setq objlay

(cdr
(assoc 8 ent_data)
)
)

(command "layer" "Color" "T" str objlay "")
)
(defun TrueColor-split (c
/)
(list (lsh (fix c) -16)
(lsh (lsh (fix c) 16)
-24)
(lsh (lsh (fix c) 24) -24)

)
)
(c:slt)

Unable to delete/move/select viewport

John.vellek providing a summary of the solutions of this issue:
Saved from: https://forums.autodesk.com/t5/autocad-forum/unable-to-delete-move-select-viewport/td-p/4364254

  • Verify all layers are on and thawed including the VP layer settings.

 

 

  • If the Viewport is on the defpoints layer, try renaming defpoints.

 

  • Double-click inside the viewport to make it active.
    Maximize the viewport by clicking the + sign in the top left corner.
    Change back to paper space and you can now see and select the viewport.

Capture.PNG

 

  • Draw a rectangle over the viewport
    Qselect the viewport
  • Capture1.PNG
    use VPCLIP (viewport is still selected)
    Select the rectangle.

John Vellek
Technical Support Specialist

* One can create a Viewport with an Object, then erase that Object.

The Viewport will remain with no way to manipulate the Viewport.

* Draw a rectangle over the top of the viewport in paperspace.

Use QUICKSELECT to select only the viewport.

Start the Viewport Clip command (VPCLIP).

It will already have the viewport selected and will prompt you to select the object to clip with.

Select the rectangle.

And You should have a workable viewport.

*  If you have issues with selecting a viewport, here is the magic fix: (if it is on the Defpoints layer) change the word defpoints to “Defpoint”  no “s”. Make a new viewport under the correct defpoints, delete the old one and purge to get rid of the corrupt layer.

* A faster fix that doesn’t involve changing the Defpoints layer: In paperspace, use ctrl+A to select everything and use shift+select to deselect everything except the viewport.  The viewport is now the only thing selected and can be moved off of the Defpoints layer

  • If you have them on Defpoints, and layer 0 is frozen or off, you can’t select anything on the
    Defpoints layer.