Match Text and Mtext Height, Width & Oblique (Lee Mac Routine)


;;; Match Text and Mtext Height, Width & Oblique (Lee Mac Routine)
;;; Saved from here: http://www.cadtutor.net/forum/showthread.php?37230-Match-Text-Height-Width-amp-Oblique/page2

(defun c:mt (/ tEnt tObj ss tStr p1 p2)
(vl-load-com)
(if (and (setq tEnt (car (nentsel "\nSelect Source Text: ")))
(wcmatch (cdadr (entget tEnt)) "ATT*,*TEXT")
(setq tObj (vlax-ename->vla-object tEnt)))
(while (setq Obj (car (nentsel "\nSelect Destination Object: ")))
(setq Obj (vlax-ename->vla-object Obj))
(cond ((vl-position (vla-get-ObjectName Obj)
'("AcDbAttribute" "AcDbAttributeDefinition" "AcDbText" "AcDbMText"))
(foreach fun '(Layer Color Height ObliqueAngle ScaleFactor StyleName)
(if (and (vlax-property-available-p tObj fun)
(vlax-property-available-p Obj fun t))
(vlax-put-property Obj fun
(vlax-get-property tObj fun))))
(cond ((and (eq (vla-get-ObjectName Obj) "AcDbMText")
(vl-position (vla-get-ObjectName tObj)
'("AcDbAttributeDefinition" "AcDbAttribute" "AcDbText")))
(vla-put-TextString Obj
(strcat "{\\Q"
(rtos (rtd (vla-get-ObliqueAngle tObj))) ";\\W"
(rtos (vla-get-ScaleFactor tObj)) ";"
(mip_mtext_unformat (vla-get-TextString Obj)) "}")))
((= (vla-get-ObjectName Obj) (vla-get-ObjectName tObj) "AcDbMText")
(vla-put-TextString Obj
(vl-String-Subst
(mip_mtext_unformat
(vla-get-TextString Obj))
(mip_mtext_unformat
(vla-get-TextString tObj))
(vla-get-TextString tObj))))
((and (eq (vla-get-ObjectName tObj) "AcDbMText")
(vl-position (vla-get-ObjectName Obj)
'("AcDbAttributeDefinition" "AcDbAttribute" "AcDbText")))
(setq tStr (vla-get-TextString tObj))
(while
(progn
(cond ((and (setq p1 (vl-string-search "\\Q" tStr))
(setq p2 (vl-string-position 59 tStr (+ p1 2))))
(vla-put-ObliqueAngle Obj
(dtr (distof (substr tStr (+ p1 3) (- p2 (+ p1 2))))))
(setq tStr (substr tStr (1+ p2))) t)
((and (setq p1 (vl-string-search "\\W" tStr))
(setq p2 (vl-string-position 59 tStr (+ p1 2))))
(vla-put-ScaleFactor Obj
(distof (substr tStr (+ p1 3) (- p2 (+ p1 2)))))
(setq tStr (substr tStr (1+ p2))) t)
(t nil)))))))
(t (princ "\nMissed, Try Again..."))))
(princ "\n<>"))
(princ))

(defun mip_MTEXT_Unformat ( Mtext / text Str )
(setq Text "")
(while (/= Mtext "")
(cond
((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
(setq Mtext (substr Mtext 3) Text (strcat Text Str)))
((wcmatch (substr Mtext 1 1) "[{}]")(setq Mtext (substr Mtext 2)))
((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[LO`~]")
(setq Mtext (substr Mtext 3)))
((wcmatch (strcase (substr Mtext 1 2)) "\\[ACFHQTW]")
(setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
((wcmatch (strcase (substr mtext 1 4)) "\\PQ[CRJD],\\PXQ") ;;;Add by KPblC
(setq mtext (substr mtext (+ 2 (vl-string-search ";" mtext)))))
((wcmatch (strcase (substr Mtext 1 2)) "\\P")
(if (or
(zerop (strlen Text))
(= " " (substr Text (strlen Text)))
(= " " (substr Mtext 3 1)))
(setq Mtext (substr Mtext 3))
(setq Mtext (substr Mtext 3) Text (strcat Text " "))))
((wcmatch (strcase (substr Mtext 1 2)) "\\S")
(setq Str (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
Text (strcat Text (vl-string-translate "#^\\" "/^\\" Str))
Mtext (substr Mtext (+ 4 (strlen Str)))))
(t (setq Text (strcat Text (substr Mtext 1 1)) Mtext (substr Mtext 2)))))
Text)

(defun rtd (x)
(* 180. (/ x pi)))

(defun dtr (x)
(* pi (/ x 180.)))
(c:mt)

Create RevCloud as Polyline with yellow solid hatch within


;;; Create RevCloud as Polyline with yellow solid hatch within.
;;; Created by Igal Averbuh 2017 (inspired by some ideas from http://www.cadtutor.net/forum/)

(defun C:RS ()
(setvar "osmode" 16384)

(setvar 'dimscale
(cond ((getdist (strcat "\nSpecify Revision Cloud Arc Length : ")))
((getvar 'dimscale))
)
)
;(command "revcloud" "A" (* 0.3125 (getvar "DIMSCALE")) "")
(command "-layer" "m" "TPZ-NOTES" "C" "1" "" "")
(command "_.spline")
(while (> (getvar "CmdActive") 0)
(command pause)
)
(command "_.revcloud" "A" (* 0.8125 (getvar "DIMSCALE")) "" "_o" "_l" "_n")
(setq hpn (getvar 'hpname))
(setvar 'hpname "SOLID")
(command "_.-BHATCH" "_S" "L" "" "")
(setvar 'hpname hpn)
(command "_.change" "L" "" "P" "C" "2" "")
(command "_.draworder" "L" "" "B")
(setvar "osmode" 167)
(princ)
)
(c:rs)

Hatch Bounding Box around selection set of entities


;;; Hatch Bounding Box around selection set of entities
;;; Created by Igal Averbuh 2017 (based on Lee Mac Routine)
;;; Saved from here: http://www.lee-mac.com/ssboundingbox.html

;; Selection Set Bounding Box - Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; sel - [sel] Selection set for which to return bounding box

(defun LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp )
(repeat (setq idx (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
(if (and (vlax-method-applicable-p obj 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
)
(setq ls1 (mapcar 'min (vlax-safearray->list llp) (cond (ls1) ((vlax-safearray->list llp))))
ls2 (mapcar 'max (vlax-safearray->list urp) (cond (ls2) ((vlax-safearray->list urp))))
)
)
)
(if (and ls1 ls2) (list ls1 ls2))
)

(defun c:bx ( / box obj sel spc )
(if (and (setq sel (ssget))
(setq box (LM:ssboundingbox sel))
)
(progn
(setq spc
(vlax-get-property (vla-get-activedocument (vlax-get-acad-object))
(if (= 1 (getvar 'cvport))
'paperspace
'modelspace
)
)
)
(if (equal 0.0 (apply '- (mapcar 'caddr box)) 1e-6)
(progn
(setq obj
(vlax-invoke spc 'addlightweightpolyline
(apply 'append
(mapcar '(lambda ( x ) (mapcar '(lambda ( y ) ((eval y) box)) x))
'(
(caar cadar)
(caadr cadar)
(caadr cadadr)
(caar cadadr)
)
)
)
)
)
(vla-put-closed obj :vlax-true)
(vla-put-elevation obj (caddar box))
)
(apply 'vlax-invoke
(vl-list* spc 'addbox
(apply 'mapcar (cons '(lambda ( a b ) (/ (+ a b) 2.0)) box))
(apply 'mapcar (cons '- (reverse box)))
)
)
)
)
)
(princ)

)
(vl-load-com) (princ)

(defun c:bb ()
(c:bx)
(setq hpn (getvar 'hpname))
(setvar 'hpname "SOLID")
(command "_.-BHATCH" "_S" "L" "" "")
(setvar 'hpname hpn)
(command "_.change" "L" "" "P" "C" "255" "")
(command "_.draworder" "L" "" "B")
)
(c:bb)

Draw Corridor along selected polyline or Map Key legend along selected polyline

;;;
;;; Minimum US/English translation by Patrice
;;;

;;;
;;; Nouvelle version de la routine CORRIDOR
;;; CORRIDOR2.LSP le 09/07/2007
;;; Taper au clavier: CORRIDORVERYNEW
;;;
;;; ATTENTION: Pour ACAD/MAP 2007/2008/2009
;;; Ne fonctionne pas sur versions precedentes
;;;
;;; Routine : CORRIDORVERYNEW from Gilles (gile)
;;;

(defun c:cr (/ *error* JoinPlines HatchPline AcDoc
Space sort inc ht ss extr col long
larg pl0 nor pl1 pl2 ps1 ps2 nb
n pt0 pa0 pt1 pt2 cut1 cut2 txt
box
)

(vl-load-com)

;; Redיfintion de *error* (fermeture du groupe d'annulation)
(defun *error* (msg)
(if (= msg "Fonction annulיe")
(princ)
(princ (strcat "\nErreur: " msg))
)
(vla-endundomark
(vla-get-activedocument (vlax-get-acad-object))
)
(princ)
)

;; Joint deux polylignes en une polyligne fermיe
(defun JoinPlines (p1 p2 / v1 v2 i lst pl)
(setq v1 (fix (vlax-curve-getEndParam p1))
v2 (fix (vlax-curve-getEndParam p2))
i 0
)
(repeat v1
(setq lst (cons (cons i (vla-getBulge p1 i)) lst)
i (1+ i)
)
)
(setq i (1+ i))
(repeat v2
(setq lst (cons (cons i (- (vla-GetBulge p2 (setq v2 (1- v2))))) lst)
i (1+ i)
)
)
(setq pl
(vlax-invoke
Space
'addLightWeightPolyline
(append (vlax-get p1 'Coordinates)
(apply 'append
(reverse (split-list (vlax-get p2 'Coordinates) 2))
)
)
)
)
(vla-put-Closed pl :vlax-true)
(mapcar '(lambda (x) (vla-SetBulge pl (car x) (cdr x))) lst)
(vla-put-Normal pl (vla-get-Normal p1))
(vla-put-Elevation pl (vla-get-Elevation p1))
(vla-delete p1)
(vla-delete p2)
pl
)

;; hachure une polyligne (SOLID)
(defun HatchPline (pl / hatch)
(setq hatch (vla-AddHatch
Space
acHatchPatternTypePredefined
"SOLID"
:vlax-true
)
)
(vlax-invoke hatch 'AppendOuterLoop (list pl))
(vla-put-Color hatch col)
(vlax-invoke sort 'MoveToBottom (list hatch))
)

;; Fonction principale
(setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
Space (if (= (getvar "CVPORT") 1)
(vla-get-PaperSpace AcDoc)
(vla-get-ModelSpace AcDoc)
)
)
(or (vlax-ldata-get "corridor" "long")
(vlax-ldata-put "corridor" "long" 40.0)
)
(or (vlax-ldata-get "corridor" "larg")
(vlax-ldata-put "corridor" "larg" 20.0)
)
(or (vlax-ldata-get "corridor" "num")
(vlax-ldata-put "corridor" "num" 1)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (initget "Oui Non")
(initget "Yes No")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(if

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (/= "Non"
; (getkword "\Numיroter les boites ? [Oui/Non] : ")
(/= "No"
(getkword "\Numbering Boxes ? [Yes/No] : ")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

)
(progn
(if (setq inc

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (getint (strcat "\nEntrez le numיro de dיpart <"
(getint (strcat "\nEnter First Number : "
)
)
)
(vlax-ldata-put "corridor" "num" inc)
(setq inc (vlax-ldata-get "corridor" "num"))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (if (setq ht (getdist (strcat "\nSpיcifiez la hauteur de texte <"
(if (setq ht (getdist (strcat "\nSpecify Text Height : "
)
)
)
(setvar "TEXTSIZE" ht)
(setq ht (getvar "TEXTSIZE"))
)
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (initget "Oui Non")
(initget "Yes No" )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (setq extr (getkword "\nBoites aux extrיmitיs seulement ? [Oui/Non] : "))
(setq extr (getkword "\nBoxes at the End only ? [Yes/No] : "))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(initget 6)
(if (setq larg

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (getdist (strcat "\nLargeur/Emprise des boites <"
(getdist (strcat "\nBoxes Width : "
)
)
)
(vlax-ldata-put "corridor" "larg" larg)
(setq larg (vlax-ldata-get "corridor" "larg"))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (if (= "Non" extr)
(if (= "No" extr)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(progn
(initget 6)
(if (setq long

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (getdist (strcat "\nLongueur des boites (3 4)
;;; (sublst '(1 2 3 4 5 6) 3 -1) -> (3 4 5 6)
;;; (sublst '(1 2 3 4 5 6) 3 12) -> (3 4 5 6)
;;; (sublst '(1 2 3 4 5 6) 3 nil) -> (3 4 5 6)

(defun sublst (lst start leng / rslt)
(or ( ((1 2) (3 4) (5 6) (7 8))
;; (split-list '(1 2 3 4 5 6 7 8) 3) -> ((1 2 3) (4 5 6) (7 8))

(defun split-list (lst n)
(if lst
(cons (sublst lst 1 n)
(split-list (sublst lst (1+ n) nil) n)
)
)
)

;;; CutPlineAtPoint
;;; Coupe la polyligne au point spיcifiי et retourne la liste des deux objets gיnיrיs
;;; (ename ou vla-object selon le type de l'argument pl)
;;;
;;; Arguments
;;; pl : la polyligne א couper (ename ou vla-object)
;;; pt : le point de coupure sur la polyligne (coordonnיes SCG)

(defun CutPlineAtPoint
(pl pt / en no pa p0 p1 pn cl l0 l1 l2 ce sp c b0 b1 b2
bp a1 a2 n wp w0 w1 w2)
(vl-load-com)
(or (= (type pl) 'VLA-OBJECT)
(setq pl (vlax-ename->vla-object pl)
en T
)
)
(setq no (vlax-get pl 'Normal)
pa (fix (vlax-curve-getParamAtPoint pl pt))
p0 (vlax-curve-getPointAtparam pl pa)
p1 (vlax-curve-getPointAtParam pl (1+ pa))
pn (reverse (cdr (reverse (trans pt 0 no))))
cl (vla-Copy pl)
l0 (vlax-get pl 'Coordinates)
l1 (append (sublst l0 1 (* 2 (1+ pa))) pn)
l2 (append pn (sublst l0 (1+ (* 2 (1+ pa))) nil))
ce (if (not (equal pt p0 1e-9))
(ArcCenterBy3Points (trans p0 0 no) pn (trans p1 0 no))
)
sp (reverse
(cdr (reverse (trans (vlax-curve-getStartPoint pl) 0 no)))
)
)
(and (= (vla-get-Closed pl) :vlax-true)
(setq c T
l2 (append l2 sp)
)
)
(repeat (setq n (if c
(fix (vlax-curve-getendParam pl))
(fix (1+ (vlax-curve-getendParam pl)))
)
)
(setq b0 (cons (vla-getBulge pl (setq n (1- n))) b0))
(vla-GetWidth pl n 'StartWidth 'EndWidth)
(setq w0 (cons (list StartWidth EndWidth) w0))
)
(setq bp (nth pa b0))
(if ce
(progn
(setq a1 (- (angle ce pn) (angle ce (trans p0 0 no)))
a2 (- (angle ce (trans p1 0 no)) (angle ce pn))
)
(if (minusp bp)
(foreach a '(a1 a2)
(if (ename pl)
)
(list pl cl)
)
)

(princ "\nTape to Invoke : CR \n")
(c:cr)

Draw a “buffer” boundary outline of User-specified width around User-selected Offsettable object(s)


;;; Draw a "buffer" boundary outline of User-specified width around User-selected Offsettable object(s)
;;; Created by Kent Cooper
;;; Saved from here: http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/buffer-lisp-code-around-pline/td-p/5489225

;|
BUFFER.lsp [command name: BF]
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]

(defun C:BF
(/ *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 BF to add buffer boundary outline(s) around object(s).")
(c:bf)

Draw bounding box around texts, mtexts and attributes in a same layer as selected entities


;;; Draw bounding box around texts, mtexts and attributes in a same layer as selected entities
;;; Created by Igal Averbuh 2017 (Inspired by Msasu routine)
;;; Saved from here: http://www.cadtutor.net/forum/showthread.php?89942-Automate-to-create-bounding-box-for-all-text-objects

(defun c:TB ( / suffixLayer ss nameEnt assocEnt nameLayer )
(if (not bns_tcircle) (load "acettxt.lsp"))

(if (setq ss (ssget '((0 . "TEXT,MTEXT,ATTDEF")))) ;select all labels from drawing

(while (> (sslength ss) 0) ;parse selection set until empty
(setq nameEnt (ssname ss 0) ;retrive first entry from selection set
assocEnt (entget nameEnt))

(setq nameLayer (strcat (cdr (assoc 8 assocEnt))))
(command "_LAYER" "_S" nameLayer "")
; )

(bns_tcircle (ssadd nameEnt) "Variable" "Rectangles" "" 0.35) ;add the bounding box

(setq ss (ssdel nameEnt ss)) ;remove processed entry from selection set
)

)
(princ)
)
(c:TB)

Draw Bounding Box around selection set of entities (Lee Mac Routine)


;;; Draw Bounding Box around selection set of entities (Lee Mac Routine)
;;; Saved from here: http://www.lee-mac.com/ssboundingbox.html

;; Selection Set Bounding Box - Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; sel - [sel] Selection set for which to return bounding box

(defun LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp )
(repeat (setq idx (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
(if (and (vlax-method-applicable-p obj 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
)
(setq ls1 (mapcar 'min (vlax-safearray->list llp) (cond (ls1) ((vlax-safearray->list llp))))
ls2 (mapcar 'max (vlax-safearray->list urp) (cond (ls2) ((vlax-safearray->list urp))))
)
)
)
(if (and ls1 ls2) (list ls1 ls2))
)

(defun c:bb ( / box obj sel spc )
(if (and (setq sel (ssget))
(setq box (LM:ssboundingbox sel))
)
(progn
(setq spc
(vlax-get-property (vla-get-activedocument (vlax-get-acad-object))
(if (= 1 (getvar 'cvport))
'paperspace
'modelspace
)
)
)
(if (equal 0.0 (apply '- (mapcar 'caddr box)) 1e-6)
(progn
(setq obj
(vlax-invoke spc 'addlightweightpolyline
(apply 'append
(mapcar '(lambda ( x ) (mapcar '(lambda ( y ) ((eval y) box)) x))
'(
(caar cadar)
(caadr cadar)
(caadr cadadr)
(caar cadadr)
)
)
)
)
)
(vla-put-closed obj :vlax-true)
(vla-put-elevation obj (caddar box))
)
(apply 'vlax-invoke
(vl-list* spc 'addbox
(apply 'mapcar (cons '(lambda ( a b ) (/ (+ a b) 2.0)) box))
(apply 'mapcar (cons '- (reverse box)))
)
)
)
)
)
(princ)
)
(vl-load-com) (princ)
(c:bb)

Alert if the drawing have Cliped Xrefs


;; XClipID.lsp [command name: XClipID]
;; To IDentify XCLIPped external references and show their clipping boundaries.
;; Draws red [see comment to specify different color] Polyline on current Layer
;; along clipping boundary of each Xref that has one, with global width 1% of
;; current view height [see comment to adjust width] for increased noticeability.
;; Kent Cooper, last edited 22 January 2015

(defun C:XC (/ *error* doc ss n xrdata xc base svnames svvals)

(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); if
(if svnames (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)

(if (setq ss (ssget "_X" (list '(0 . "INSERT") (cons 410 (getvar 'ctab)))))
(progn ; then
(setq n (sslength ss))
(while (and (not xc) (> n 0)); haven't found one yet, nor reached end of selection
(if
(and
(setq xrdata (entget (ssname ss (setq n (1- n)))))
(assoc 1 (tblsearch "block" (cdr (assoc 2 xrdata)))); it's an Xref
(assoc 360 xrdata); possibly Xclipped
); and
(setq xc (assoc 360 (entget (cdr (assoc 360 xrdata))))); then --
; [nil if none] found nested 360 entry; stop loop
); if
); while
); progn
); if
(if xc
(progn ; then -- found at least one; add red Polylines to all
(setq
base (entlast); reference last object
svnames '(cecolor cmdecho); System Variable names
svvals (mapcar 'getvar svnames); current values
); setq
(mapcar 'setvar svnames '("red" 0)); <-- edit "red" if different color desired [in quotes even if numerical]
(command "_.xclip" "_all" "" "_polyline")
(while (setq base (entnext base))
(entmod (append (entget base) (list (cons 43 (/ (getvar 'viewsize) 100))))); <-- edit 100 for desired width
); while
(mapcar 'setvar svnames svvals); reset System Variables
); progn
(alert "No Xclipped Xref(s) found in current space."); else
); if

(vla-endundomark doc)
(princ)
); defun
(c:xc)

Merge some autocad tables to one


(defun C:MT (/ col cols1 cols2 lastrow response rows1
rows2 ss start tblobj1 tblobj2 x)
(vl-load-com)
(princ "\n*** Select First table ***")
(if (setq ss (ssget "_:S:E:L" '((0 . "ACAD_TABLE"))))
(setq tblobj1 (vlax-ename->vla-object (ssname ss 0)))
)
(if (and
tblobj1
(princ "\n*** Select other tables ***")
(setq ss nil ss (ssget "_:L" '((0 . "ACAD_TABLE"))))
(or (ssdel (vlax-vla-object->ename tblobj1) ss) t)
(> (sslength ss) 0)
)
(progn
(foreach tblobj2 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq
rows1 (vla-get-rows tblobj1)
tblobj2 (vlax-ename->vla-object tblobj2)
rows2 (vla-get-rows tblobj2)
lastrow rows2
cols1 (vla-get-columns tblobj1)
cols2 (vla-get-columns tblobj2)
)
(if (not (equal cols1 cols2))
(progn
(alert "There is not equivalent number of rows found. Error...")
(exit)
(princ)
)
)
(if (eq :vlax-false (vla-get-titlesuppressed tblobj2))
(progn
(setq lastrow (1- lastrow))
(setq start 1))
(setq start 0))
(if (eq :vlax-false (vla-get-headersuppressed tblobj2))
(progn
(setq lastrow (1- lastrow))
(setq start 2))
(setq start 0))
(vla-put-RegenerateTableSuppressed tblobj1 :vlax-false)
(vla-insertrows
tblobj1
rows1
(vla-getrowheight tblobj1 (1- rows1))
lastrow)

(repeat lastrow
(setq col 0)
(repeat cols1
(cond
((eq (vla-GetCellType tblobj2 start col) acBlockCell)
(vla-SetCellType tblobj1 rows1 col acBlockCell)
(vla-setcellalignment tblobj1 rows1 col (vla-getcellalignment tblobj2 start col))
(vla-setblockscale tblobj1 rows1 col (vla-getblockscale tblobj2 start col))
(if
(and
(wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
(vlax-method-applicable-p tblobj1 'getblocktablerecordid32)
)
(vla-setblocktablerecordid32
tblobj1
rows1
col
(vla-getblocktablerecordid32 tblobj2 start col)
:vlax-false
)
(vla-setblocktablerecordid
tblobj1
rows1
col
(vla-getblocktablerecordid tblobj2 start col)
:vlax-false
)
)
)
((eq (vla-GetCellType tblobj2 start col) acTextCell)
(vla-setcellalignment tblobj1 rows1 col (vla-getcellalignment tblobj2 start col))
(vla-SetCellTextHeight tblobj1 rows1 col (vla-GetCellTextHeight tblobj2 start col))
(vla-SetCellTextStyle tblobj1 rows1 col (vla-GetCellTextStyle tblobj2 start col))
(vla-settext
tblobj1
rows1
col
(vla-gettext tblobj2 start col))
)
(t nil)
)
(setq col (1+ col)))
(setq start (1+ start))
(setq rows1 (1+ rows1)))
(vla-put-RegenerateTableSuppressed tblobj1 :vlax-true)
)
(initget 1 "Yes No")
(setq response (getkword
"\nAre you want to delete the tables [Yes/No] : "))
(if (eq "Yes" response)
(mapcar 'vla-delete (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
)
;;; (mapcar (function (lambda (x)
;;; (vl-catch-all-apply
;;; (function (lambda ()
;;; (vlax-release-object x))))))
;;; (list tblobj2 tblobj1)
;;; )
)
(alert
"nothing selected or selected less than 2 tables. Error...")
)
(princ)
)
(princ "\n >> Start command with MT to merge tables")
(princ)
(c:mt)

Draw Arrow as Polyline and convert it to block with user defined insertion point


;;; Draw Arrow as Polyline and convert it to block with user defined insertion point
;;; Created an combined from existing subroutines by Igal Averbuh 2017
;;; Based on approaches of other developers with great respect to them

;;--------------------=={ Change Block Base Point }==-------------------;;
;; ;;
;; This program allows the user to change the base point for all ;;
;; block references of a block definition in a drawing. ;;
;; ;;
;; The program offers two commands: ;;
;; ;;
;; ------------------------------------------------------------------ ;;
;; CBP (Change Base Point) ;;
;; ------------------------------------------------------------------ ;;
;; ;;
;; This command will retain the insertion point coordinates for all ;;
;; references of the selected block. Hence visually, the block ;;
;; components will be moved around the insertion point when the ;;
;; base point is changed. ;;
;; ;;
;; ------------------------------------------------------------------ ;;
;; CBPR (Change Base Point Retain Reference Position) ;;
;; ------------------------------------------------------------------ ;;
;; ;;
;; This command will retain the position of the each block reference ;;
;; of the selected block. Hence, each block reference will be moved ;;
;; to retain the visual position when the base point is changed. ;;
;; ;;
;; ------------------------------------------------------------------ ;;
;; ;;
;; Upon issuing a command syntax at the AutoCAD command-line, the ;;
;; program will prompt the user to select a block for which to change ;;
;; the base point. ;;
;; ;;
;; Following a valid selection, the user is then prompted to specify ;;
;; a new base point relative to the selected block. ;;
;; ;;
;; The block definition (and block reference depending on the command ;;
;; used) will then be modified to reflect the new block base point. ;;
;; ;;
;; If the selected block is attributed, an ATTSYNC operation will ;;
;; also be performed to ensure all attributes are in the correct ;;
;; positions relative to the new base point. ;;
;; ;;
;; Finally, the active viewport is regenerated to reflect the changes ;;
;; throughout all references of the block. ;;
;; ;;
;; The program will furthermore perform successfully with rotated & ;;
;; scaled block references, constructed in any UCS plane. ;;
;; ;;
;; ------------------------------------------------------------------ ;;
;; Please Note: ;;
;; ------------------------------------------------------------------ ;;
;; ;;
;; A REGEN is required if the UNDO command is used to undo the ;;
;; operations performed by this program. ;;
;; ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Version 1.5 - 20-10-2013 ;;
;;----------------------------------------------------------------------;;

;; Retains Insertion Point Coordinates
(defun c:cbp nil (LM:changeblockbasepoint nil))

;; Retains Block Reference Position
(defun c:cbpr nil (LM:changeblockbasepoint t))

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

(defun LM:changeblockbasepoint ( flg / *error* bln cmd ent lck mat nbp vec )

(defun *error* ( msg )
(foreach lay lck (vla-put-lock lay :vlax-true))
(if (= 'int (type cmd)) (setvar 'cmdecho cmd))
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)

(while
(progn (setvar 'errno 0) (setq ent (car (entsel "\nSelect Block: ")))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (= 'ename (type ent))
(if (/= "INSERT" (cdr (assoc 0 (entget ent))))
(princ "\nSelected object is not a block.")
)
)
)
)
)
(if (and (= 'ename (type ent)) (setq nbp (getpoint "\nSpecify New Base Point: ")))
(progn
(setq mat (car (revrefgeom ent))
vec (mxv mat (mapcar '- (trans nbp 1 0) (trans (cdr (assoc 10 (entget ent))) ent 0)))
bln (LM:blockname (vlax-ename->vla-object ent))
)
(LM:startundo (LM:acdoc))
(vlax-for lay (vla-get-layers (LM:acdoc))
(if (= :vlax-true (vla-get-lock lay))
(progn
(vla-put-lock lay :vlax-false)
(setq lck (cons lay lck))
)
)
)
(vlax-for obj (vla-item (vla-get-blocks (LM:acdoc)) bln)
(vlax-invoke obj 'move vec '(0.0 0.0 0.0))
)
(if flg
(vlax-for blk (vla-get-blocks (LM:acdoc))
(if (= :vlax-false (vla-get-isxref blk))
(vlax-for obj blk
(if
(and
(= "AcDbBlockReference" (vla-get-objectname obj))
(= bln (LM:blockname obj))
(vlax-write-enabled-p obj)
)
(vlax-invoke obj 'move '(0.0 0.0 0.0) (mxv (car (refgeom (vlax-vla-object->ename obj))) vec))
)
)
)
)
)
(if (= 1 (cdr (assoc 66 (entget ent))))
(progn
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(vl-cmdf "_.attsync" "_N" bln)
(setvar 'cmdecho cmd)
)
)
(foreach lay lck (vla-put-lock lay :vlax-true))
(vla-regen (LM:acdoc) acallviewports)
(LM:endundo (LM:acdoc))
)
)
(princ)
)

;; RefGeom (gile)
;; Returns a list whose first item is a 3x3 transformation matrix and
;; second item the object insertion point in its parent (xref, block or space)

(defun refgeom ( ent / ang enx mat ocs )
(setq enx (entget ent)
ang (cdr (assoc 050 enx))
ocs (cdr (assoc 210 enx))
)
(list
(setq mat
(mxm
(mapcar '(lambda ( v ) (trans v 0 ocs t))
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
(mxm
(list
(list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(list
(list (cdr (assoc 41 enx)) 0.0 0.0)
(list 0.0 (cdr (assoc 42 enx)) 0.0)
(list 0.0 0.0 (cdr (assoc 43 enx)))
)
)
)
)
(mapcar '- (trans (cdr (assoc 10 enx)) ocs 0)
(mxv mat (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx))))))
)
)
)

;; RevRefGeom (gile)
;; The inverse of RefGeom

(defun revrefgeom ( ent / ang enx mat ocs )
(setq enx (entget ent)
ang (cdr (assoc 050 enx))
ocs (cdr (assoc 210 enx))
)
(list
(setq mat
(mxm
(list
(list (/ 1.0 (cdr (assoc 41 enx))) 0.0 0.0)
(list 0.0 (/ 1.0 (cdr (assoc 42 enx))) 0.0)
(list 0.0 0.0 (/ 1.0 (cdr (assoc 43 enx))))
)
(mxm
(list
(list (cos ang) (sin ang) 0.0)
(list (- (sin ang)) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(mapcar '(lambda ( v ) (trans v ocs 0 t))
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
)
)
)
(mapcar '- (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
(mxv mat (trans (cdr (assoc 10 enx)) ocs 0))
)
)
)

;; 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)
)

;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices

(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)

;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix

(defun trp ( m )
(apply 'mapcar (cons 'list m))
)

;; Block Name - Lee Mac
;; Returns the true (effective) name of a supplied block reference

(defun LM:blockname ( obj )
(if (vlax-property-available-p obj 'effectivename)
(defun LM:blockname ( obj ) (vla-get-effectivename obj))
(defun LM:blockname ( obj ) (vla-get-name obj))
)
(LM:blockname obj)
)

;; 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
; (strcat
; "\n:: ChangeBlockBasePoint.lsp | Version 1.5 | \\U+00A9 Lee Mac "
; (menucmd "m=$(edtime,0,yyyy)")
; " http://www.lee-mac.com ::"
; ""
; ""
; ""
; )
;)
(princ)

;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;

;;; Copy entities and paste it as block with insertion point 0,0,0 at once
;;; Created by Henrique hmsilva http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/copy-and-paste-as-block/td-p/6022554
;;; Modified by Igal Averbuh 2016
(defun c:cpb (/ ss)
(command "ucs" "w")
(setvar "cmdecho" 0)
(command "-layer" "u" "*" "")
(princ "\nSelect objects to copy from 0,0,0 and paste as block:")
(setq ss (ssget))

(command "_.copybase" '(0.0 0.0 0.0) ss "" "_.pasteblock" '(0.0 0.0 0.0))
(command "erase" ss "")

(command "ucs" "previous")
(setvar "ucsicon" 1)
(setvar "cmdecho" 1)
(princ)
(c:CBPR)
)
;(c:cpb)

(defun c:ah (/ a b c wid)
(vl-load-com)
(setq
a (getpoint "Pick Arrow Head...\n")
b (getpoint a "Pick Arrow Tail...\n")
c (polar a (angle a b) (/ (distance a b) 3.0))
wid (/ (distance a b) 6.0)
)
(vla-setWidth
(vlax-ename->vla-object
(entmakex
(append
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 3)
)
(mapcar
(function (lambda (p) (cons 10 (trans p 1 0))))
(list a c b)
)
)
)
)
0
0.0
wid
)
(princ)
(c:cpb)
)
(c:ah)