• Add-On’s
  • Download
  • History of AutoLISP
  • Lisp Resources
  • Run an AutoLISP

LispBox

~ This blog was initially created for people, who love autolisp routines, as I love it.

Monthly Archives: October 2015

Align Text to Curve

27 Tuesday Oct 2015

Posted by danglar71 in Text

≈ Leave a comment

;;----------------------=={ Align Text to Curve }==---------------------;;
;; ;;
;; ----------------------------------- ;;
;; Program Overview ;;
;; ----------------------------------- ;;
;; This program enables the user to dynamically align a new or ;;
;; existing Text or MText object to a selected curve, with intuitive ;;
;; placement controls available. ;;
;; ;;
;; ----------------------------------- ;;
;; User Input ;;
;; ----------------------------------- ;;
;; Upon issuing the command syntax 'atc' at the AutoCAD command-line, ;;
;; the user is prompted to select a Text or MText object to align. ;;
;; At this prompt, the user also has the option to create a new Text ;;
;; or MText object, or configure the program settings. ;;
;; ;;
;; If the 'New' option is chosen, the user is prompted to enter the ;;
;; content for the new text object, or may press 'Enter' to return to ;;
;; the previous prompt. ;;
;; ;;
;; If the 'Settings' option is chosen, the user is presented with a ;;
;; dialog interface through which several program parameters may be ;;
;; configured - these settings are detailed in the section below. ;;
;; ;;
;; The user is then prompted to select a curve to which the text will ;;
;; be dynamically aligned. The program is compatible for use with ;;
;; Lines, LWPolylines, 2D (Heavy) Polylines, 3D Polylines, Arcs, ;;
;; Circles, Ellipses, Elliptical Arcs & Splines; furthermore, these ;;
;; objects may be primary or nested (to any depth) within a block or ;;
;; xref. ;;
;; ;;
;; ----------------------------------- ;;
;; Dynamic Text Alignment ;;
;; ----------------------------------- ;;
;; Following valid selection of a curve, the new or existing Text or ;;
;; MText object is dynamically aligned to the curve based on the ;;
;; position of the AutoCAD cursor. ;;
;; ;;
;; During text alignment, several controls are available at the ;;
;; command-line to refine the text position & other properties; these ;;
;; controls are individually detailed below: ;;
;; ;;
;; [ Enter ] - (or Esc/Space/Right-Click) Exit program (Cancel) ;;
;; [ Click ] - Place text ;;
;; [ +/- ] - Incrementally increase/decrease text offset ;;
;; [ O ] - Specify exact text offset ;;
;; [ ] - Rotate text by 45 degrees ;;
;; [ R ] - Specify exact text rotation (relative to curve) ;;
;; [ Y ] - Toggle text readability ;;
;; [ B ] - Toggle MText Background Mask ;;
;; ;;
;; ----------------------------------- ;;
;; Program Settings ;;
;; ----------------------------------- ;;
;; Upon selecting the 'Settings' option when prompted, the user is ;;
;; presented with a dialog interface offering the following options: ;;
;; ;;
;; Object type for new text: this setting determines whether the ;;
;; program will create a single-line Text object or MText object when ;;
;; the user opts to create a new text. ;;
;; ;;
;; Justification for new text: this setting controls the justification ;;
;; of any new text object created by the program. ;;
;; ;;
;; Text Offset Factor: this is the default offset factor of the text ;;
;; from the selected curve, as a multiple of the text height. This ;;
;; factor may also be zero if the text is to be positioned directly ;;
;; over the selected curve. ;;
;; ;;
;; Text Rotation: this setting controls the default rotation of the ;;
;; text relative to the selected curve. ;;
;; ;;
;; Text Readability: this toggle determines whether the text should ;;
;; be rotated to preserve readability, i.e. the text will never appear ;;
;; upside-down. ;;
;; ;;
;; Background Mask: this toggle controls whether a background mask is ;;
;; used when aligning MText objects. ;;
;; ;;
;; Multiple Text Mode: if this setting is enabled, the program will ;;
;; continuously generate text objects to align with the selected curve ;;
;; until the user exits the program. ;;
;; ;;
;; ----------------------------------- ;;
;; Notes ;;
;; ----------------------------------- ;;
;; The program is compatible with all full versions of AutoCAD ;;
;; supporting Visual LISP with ActiveX (COM) functionality (that is, ;;
;; AutoCAD 2000 onwards on a Windows OS). ;;
;; ;;
;; The program will perform successfully under all UCS & View ;;
;; settings and with Annotative Text Styles. ;;
;; ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Version 1.2 - 12-10-2013 ;;
;; ;;
;; First release - previously 'CurveAlignedTextV1-1.lsp'. ;;
;;----------------------------------------------------------------------;;

(setq atc:version "1.2")

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

(defun c:mon

(
/
*error*
ang
bak
cfg
dcl def dis
ent enx
gr1 gr2
hgt
jus
mat msg mtp
nrm
off
pi2 prn prp pt1 pt2
red rot
sav sel str sym
tmp txt typ
uxa
)

(defun *error* ( msg )
(if
(and
(= 'list (type def))
(= 'str (type cfg))
(findfile cfg)
)
(atc:writeconfig cfg (mapcar 'eval (mapcar 'car def)))
)
(if
(and
(= 'vla-object (type txt))
(not (vlax-erased-p txt))
(vlax-write-enabled-p txt)
)
(if (= 'list (type prp))
(foreach x prp
(if (vlax-property-available-p txt (car x) t)
(vl-catch-all-apply 'vlax-put-property (cons txt x))
)
)
(vl-catch-all-apply 'vla-delete (list txt))
)
)
(if
(and
(= 'list (type mat))
(= 'ename (type ent))
(entget ent)
)
(entdel ent)
)
(atc:endundo (atc:acdoc))
(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(princ (strcat "\nError: " msg))
)
(princ)
)

(atc:startundo (atc:acdoc))
(cond
( (or (atc:layerlocked (getvar 'clayer))
(atc:layerlocked "0")
)
(princ "\nCurrent layer or layer \"0\" locked.")
)
( (null (vl-file-directory-p (setq sav (atc:savepath))))
(princ "\nSave path invalid.")
)
( (progn
(setq def
'(
(typ . "txt")
(jus . "Middle-Center")
(off . 1.0)
(rot . 0.0)
(red . t)
(bak . nil)
(mtp . nil)
)
)
(setq cfg (strcat sav "\\LMAC_ATC_V" (vl-string-translate "." "-" atc:version) ".cfg")
dcl (strcat sav "\\LMAC_ATC_V" (vl-string-translate "." "-" atc:version) ".dcl")
)
(if (not (findfile cfg))
(atc:writeconfig cfg (mapcar 'cdr def))
)
(atc:readconfig cfg (setq sym (mapcar 'car def)))

(while
(progn
(setvar 'errno 0)
(initget "New Settings Exit")
(setq sel (entsel "\nSelect text to align [New/Settings] : "))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (= 'list (type sel))
(setq ent (car sel)
enx (entget ent)
)
(cond
( (not (wcmatch (cdr (assoc 0 enx)) "TEXT,MTEXT"))
(princ "\nObject must be either Text or MText.")
)
( (atc:layerlocked (cdr (assoc 8 enx)))
(princ "\nObject is on a locked layer.")
)
( t
(setq txt (vlax-ename->vla-object ent)
prp (atc:getproperties txt)
)
nil
)
)
)
( (= "Exit" sel)
nil
)
( (= "Settings" sel)
(mapcar 'set sym (atc:settings dcl (mapcar 'eval sym)))
)
( (= "New" sel)
(= "" (vl-string-trim " \t\n" (setq str (getstring t "\nSpecify text : "))))
)
)
)
)
(not
(or (= 'vla-object (type txt))
(and (= 'str (type str)) (/= "" (vl-string-trim " \t\n" str)))
)
)
)
(atc:writeconfig cfg (mapcar 'eval sym))
)
( (progn
(while
(progn
(setvar 'errno 0)
(setq sel (nentselp "\nSelect curve to align text : "))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (= 'ename (type (car sel)))
(if
(not
(or (= "VERTEX" (cdr (assoc 0 (entget (car sel)))))
(not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getendparam (list (car sel)))))
)
)
(princ "\nInvalid object selected.")
)
)
)
)
)
(null sel)
)
)
( (not
(or
(and
(setq mat (caddr sel))
(setq ent (atc:copynested (car sel) mat))
)
(and
(= "VERTEX" (cdr (assoc 0 (entget (car sel)))))
(setq ent (cdr (assoc 330 (entget (car sel)))))
)
(setq ent (car sel))
)
)
(princ "\nUnable to recreate nested entity.")
)
( t
(if (null txt)
(if (= "txt" typ)
(progn
(setq txt
(vla-addtext
(vlax-get-property (atc:acdoc)
(if (= 1 (getvar 'cvport))
'paperspace
'modelspace
)
)
str
(vlax-3D-point (trans (cadr sel) 1 0))
(atc:styleheight (getvar 'textstyle))
)
)
(vla-put-alignment txt
(eval
(cadr
(assoc jus
'(
("Left" acalignmentleft)
("Center" acalignmentcenter)
("Right" acalignmentright)
("Middle" acalignmentmiddle)
("Top-Left" acalignmenttopleft)
("Top-Center" acalignmenttopcenter)
("Top-Right" acalignmenttopright)
("Middle-Left" acalignmentmiddleleft)
("Middle-Center" acalignmentmiddlecenter)
("Middle-Right" acalignmentmiddleright)
("Bottom-Left" acalignmentbottomleft)
("Bottom-Center" acalignmentbottomcenter)
("Bottom-Right" acalignmentbottomright)
)
)
)
)
)
)
(progn
(setq txt
(vla-addmtext
(vlax-get-property (atc:acdoc)
(if (= 1 (getvar 'cvport))
'paperspace
'modelspace
)
)
(vlax-3D-point (trans (cadr sel) 1 0))
( (lambda ( box ) (- (caadr box) (caar box)))
(textbox
(list
(cons 01 (strcat str "."))
(cons 40 (atc:styleheight (getvar 'textstyle)))
(cons 07 (getvar 'textstyle))
)
)
)
str
)
)
(vla-put-attachmentpoint txt
(eval
(cadr
(assoc jus
'(
("Top-Left" acattachmentpointtopleft)
("Top-Center" acattachmentpointtopcenter)
("Top-Right" acattachmentpointtopright)
("Middle-Left" acattachmentpointmiddleleft)
("Middle-Center" acattachmentpointmiddlecenter)
("Middle-Right" acattachmentpointmiddleright)
("Bottom-Left" acattachmentpointbottomleft)
("Bottom-Center" acattachmentpointbottomcenter)
("Bottom-Right" acattachmentpointbottomright)
)
)
)
)
)
(vla-put-height txt (atc:styleheight (getvar 'textstyle)))
(if bak (vla-put-backgroundfill txt :vlax-true))
)
)
)
(if
(and
(= "AcDbText" (vla-get-objectname txt))
(/= acalignmentleft (vla-get-alignment txt))
)
(setq prn 'textalignmentpoint)
(setq prn 'insertionpoint)
)
(setq hgt (vla-get-height txt)
pi2 (/ pi -2.0)
nrm (trans '(0.0 0.0 1.0) 1 0 t)
uxa (if (= "AcDbText" (vla-get-objectname txt)) (angle '(0.0 0.0 0.0) (trans (getvar 'ucsxdir) 0 nrm t)) 0.0)
msg (strcat "\n[+/-] for [O]ffset | [] for [R]otation | Readabilit[y] |"
(if (= "AcDbMText" (vla-get-objectname txt))
" [B]ackground Mask | : "
" : "
)
)
)
(princ msg)
(while
(progn
(setq gr1 (grread t 15 0)
gr2 (cadr gr1)
gr1 (car gr1)
)
(cond
( (or (= 5 gr1) (= 3 gr1))
(setq pt2 (trans gr2 1 0)
pt1 (vlax-curve-getclosestpointto ent pt2)
)
(if (not (equal pt1 pt2 1e-8))
(progn
(setq dis (/ (* hgt off) (distance pt1 pt2))
ang (+ (angle (trans pt1 0 1) gr2) uxa rot pi2)
)
(vlax-put-property txt prn (vlax-3D-point (mapcar '(lambda ( a b ) (+ a (* (- b a) dis))) pt1 pt2)))
(vla-put-rotation txt (if red (atc:readable ang) ang))
)
)
(cond
( (= 5 gr1))
( mtp
(setq txt (vla-copy txt)
prp nil
)
t
)
)
)
( (= 2 gr1)
(cond
( (member gr2 '(043 061))
(setq off (+ off 0.1))
)
( (member gr2 '(045 095))
(setq off (- off 0.1))
)
( (member gr2 '(044 060))
(setq rot (+ rot (/ pi 4.0)))
)
( (member gr2 '(046 062))
(setq rot (- rot (/ pi 4.0)))
)
( (member gr2 '(013 032 069 101))
(*error* nil)
nil
)
( (member gr2 '(089 121))
(if (setq red (not red))
(princ "\n")
(princ "\n")
)
(princ msg)
)
( (member gr2 '(066 098))
(if (= "AcDbMText" (vla-get-objectname txt))
(progn
(vlax-put txt 'backgroundfill (~ (vlax-get txt 'backgroundfill)))
(if (setq bak (= -1 (vlax-get txt 'backgroundfill)))
(princ "\n")
(princ "\n")
)
)
(princ "\nBackground mask only available with MText.")
)
(princ msg)
)
( (member gr2 '(082 114))
(if (setq tmp (getangle (strcat "\nSpecify Rotation : ")))
(setq rot tmp)
)
(princ msg)
)
( (member gr2 '(079 111))
(if (setq tmp (getdist (strcat "\nSpecify Offset : ")))
(setq off (/ tmp hgt))
)
(princ msg)
)
( t )
)
)
( (member gr1 '(11 25))
(*error* nil)
nil
)
( t )
)
)
)
(if mat (entdel ent))
(atc:writeconfig cfg (mapcar 'eval sym))
)
)
(atc:endundo (atc:acdoc))
(princ)
)

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

(defun atc:readable ( a )
( (lambda ( a )
(if (and (< (* pi 0.5) a) (vla-object tmp) (vlax-tmatrix mat)))
tmp
)

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

(defun atc:entmakex ( enx )
(entmakex
(append
(vl-remove-if
(function
(lambda ( x )
(or (member (car x) '(005 006 008 039 048 062 102 370))
(= 'ename (type (cdr x)))
)
)
)
enx
)
'(
(006 . "CONTINUOUS")
(008 . "0")
(039 . 0.0)
(048 . 1.0)
(062 . 7)
(370 . 0)
)
)
)
)

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

(defun atc:getproperties ( obj )
(vl-remove nil
(mapcar
(function
(lambda ( prp )
(if (vlax-property-available-p obj prp t)
(list prp (vlax-get-property obj prp))
)
)
)
'(
insertionpoint
textalignmentpoint
backgroundfill
rotation
)
)
)
)

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

(defun atc:settings ( dcl lst / *error* alg bak dch jus mtp off off:str red rot rot:str typ typ:fun )

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

(cond
( (not (atc:writedcl dcl))
(princ "\nDCL file could not be written.")
)
( (<= (setq dch (load_dialog dcl)) 0)
(princ "\nDCL file could not be loaded.")
)
( (not (new_dialog "atc" dch))
(princ "\nProgram dialog could not be loaded.")
)
( t
(mapcar 'set '(typ jus off rot red bak mtp) lst)

(set_tile typ "1")
(
(setq typ:fun
(lambda ( typ )
(setq alg (atc:justlist typ))
(set_tile "jus"
(itoa
(cond
( (vl-position jus alg))
( (setq jus (car alg)) 0)
)
)
)
(if (= "mtx" typ)
(mode_tile "bak" 0)
(mode_tile "bak" 1)
)
)
)
typ
)
(action_tile "jus" "(setq jus (nth (atoi $value) alg))")
(action_tile "txt" "(typ:fun (setq typ $key))")
(action_tile "mtx" "(typ:fun (setq typ $key))")

(set_tile "off" (setq off:str (rtos off)))
(action_tile "off" "(setq off:str $value)")

(set_tile "rot" (setq rot:str (angtos rot)))
(action_tile "rot" "(setq rot:str $value)")

(foreach key '("red" "bak" "mtp")
(set_tile key (if (eval (read key)) "1" "0"))
(action_tile key (strcat "(setq " key " (= \"1\" $value))"))
)
(action_tile "accept"
(vl-prin1-to-string
'(cond
( (not (distof off:str))
(alert "\nOffset Factor must be numerical.")
(mode_tile "off" 2)
)
( (not (angtof rot:str))
(alert "\nText Rotation must be numerical.")
(mode_tile "rot" 2)
)
( (setq off (distof off:str)
rot (angtof rot:str)
)
(done_dialog 1)
)
)
)
)

(if (= 1 (start_dialog))
(setq lst (list typ jus off rot red bak mtp))
)
)
)
(if (< 0 dch)
(unload_dialog dch)
)
lst
)

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

(defun atc:justlist ( typ / lst )
(start_list "jus")
(foreach itm
(setq lst
(append
(if (= "txt" typ)
'(
"Left"
"Center"
"Right"
"Middle"
)
)
'(
"Top-Left"
"Top-Center"
"Top-Right"
"Middle-Left"
"Middle-Center"
"Middle-Right"
"Bottom-Left"
"Bottom-Center"
"Bottom-Right"
)
)
)
(add_list itm)
)
(end_list)
lst
)

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

(defun atc:layerlocked ( lay / def )
(and
(setq def (tblsearch "layer" lay))
(= 4 (logand 4 (cdr (assoc 70 def))))
)
)

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

(defun atc:writedcl ( dcl / des )
(cond
( (findfile dcl))
( (setq des (open dcl "w"))
(foreach x
'(
"edt : edit_box"
"{"
" edit_width = 8;"
" edit_limit = 10;"
" alignment = left;"
"}"
"atc : dialog"
"{"
" label = \"Settings\";"
" spacer;"
" : text"
" {"
" label = \"Object type for new text:\";"
" }"
" : radio_row"
" {"
" alignment = centered;"
" fixed_width = true;"
" : radio_button"
" {"
" key = \"txt\";"
" label = \"Text\";"
" }"
" : radio_button"
" {"
" key = \"mtx\";"
" label = \"MText\";"
" }"
" }"
" spacer;"
" : text"
" {"
" label = \"Justification for new text:\";"
" }"
" : popup_list"
" {"
" key = \"jus\";"
" }"
" spacer;"
" : edt"
" {"
" key = \"off\";"
" label = \"Offset Factor:\";"
" }"
" : edt"
" {"
" key = \"rot\";"
" label = \"Text Rotation:\";"
" }"
" spacer;"
" : toggle"
" {"
" key = \"red\";"
" label = \"Retain Text Readability\";"
" }"
" : toggle"
" {"
" key = \"bak\";"
" label = \"MText Background Mask\";"
" }"
" : toggle"
" {"
" key = \"mtp\";"
" label = \"Multiple Text Mode\";"
" }"
" spacer;"
" ok_cancel;"
"}"
)
(write-line x des)
)
(setq des (close des))
(while (not (findfile dcl)))
dcl
)
)
)

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

(defun atc:writeconfig ( cfg lst / _tostring des )

(defun _tostring ( x / dim )
(cond
( (= 'int (type x))
(itoa x)
)
( (= 'real (type x))
(setq dim (getvar 'dimzin))
(setvar 'dimzin 0)
(setq x (rtos x 2 8))
(setvar 'dimzin dim)
x
)
( (vl-prin1-to-string x))
)
)

(if (setq des (open cfg "w"))
(progn
(foreach x lst (write-line (_tostring x) des))
(setq des (close des))
t
)
)
)

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

(defun atc:readconfig ( cfg lst / des itm )
(if
(and
(setq cfg (findfile cfg))
(setq des (open cfg "r"))
)
(progn
(foreach sym lst
(if (setq itm (read-line des))
(set sym (read itm))
)
)
(setq des (close des))
t
)
)
)

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

(defun atc:savepath ( / tmp )
(if (setq tmp (getvar 'roamablerootprefix))
(strcat (atc:fixdir tmp) "\\Support")
(atc:fixdir (getvar 'tempprefix))
)
)

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

(defun atc:fixdir ( dir )
(vl-string-right-trim "\\" (vl-string-translate "/" "\\" dir))
)

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

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

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

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

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

(defun atc:acdoc nil
(eval (list 'defun 'atc:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(atc:acdoc)
)

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

(vl-load-com)
(princ
(strcat
"\n:: AlignTextToCurve.lsp | Version "
atc:version
" | \\U+00A9 Lee Mac "
(menucmd "m=$(edtime,0,yyyy)")
" http://www.lee-mac.com ::"
"\n:: Type \"mon\" to Invoke ::"
)
)
(princ)

;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;
(c:mon)

Break Multiple Lines

25 Sunday Oct 2015

Posted by danglar71 in draw

≈ Leave a comment

;;==========================================================================

;; This code is use to break multiple lines at intersection with another lines

;; with an option of just break a line or leave a gap in between.

;; Modified by Ajilal Vijayan

;;==========================================================================

(defun C:MBR (/ P1 P2 P3 P4 P5 P6 P7 SS1 SS2 INDEX1 INDEX2 ENAME1 ENAME2 ELIST1 ELIST2 BRKLEN OFFDISDAT)

(setq OSMDE (getvar "osmode"))

(setvar "osmode" 0)

(setq PCKBX (getvar "pickbox"))

(setq OFFDISDAT (getdist (strcat "\nSpecify offset distance from intersections: : ")))

(if OFFDISDAT

(setq OFFDISDAT (rtos OFFDISDAT 2 3))

);if

(if (/= OFFDISDAT "")

(setq OFFDISNUM OFFDISDAT)

)

(setq BRKLEN (atof OFFDISNUM))

(prompt "\nSELECT BREAKING LINES...")

(while (or (not SS1) (= 0 (sslength SS1)))

(setq SS1 (ssget '((0 . "LINE"))))

)

(setq INDEX1 0)

(repeat (sslength SS1)

(progn

(setq ENAME1 (ssname SS1 INDEX1))

(setq ELIST1 (entget ENAME1))

(setq P1 (cdr (assoc 10 ELIST1)))

(setq P2 (cdr (assoc 11 ELIST1)))

(prompt "\nSELECT LINES THAT INTERSECT BREAKING LINES...")

(while (or (not SS2) (= 0 (sslength SS2)))

(setq SS2 (ssget '((0 . "LINE"))))

)

(setq INDEX2 0)

(repeat (sslength SS2)

(progn

(setq ENAME2 (ssname SS2 INDEX2))

(setq ELIST2 (entget ENAME2))

(setq P3 (cdr (assoc 10 ELIST2)))

(setq P4 (cdr (assoc 11 ELIST2)))

(setq P5 (inters P1 P2 P3 P4 onseg))

(setq P6 (polar P5 (angle P3 P4) BRKLEN))

(setq P7 (polar P5 (angle P4 P3) BRKLEN))

(command "draworder" ENAME2 "" "F")

(if (= BRKLEN 0)

(command "break" P5 "@")

(command "break" P6 "none" P7)

)

)

(setq INDEX2 (1+ INDEX2))

)

)

(setq INDEX1 (1+ INDEX1))

)

(setvar "osmode" OSMDE)

(princ (strcat "\n" (itoa (sslength SS2)) " Lines have been broken"))

(princ)

)

(setq OFFDISNUM "0")

;;==========================================================================
(c:mbr)

Automatic coordinate labeling

22 Thursday Oct 2015

Posted by danglar71 in Coordinates

≈ Leave a comment

; Automatic coordinate labeling
; Edwin Prakoso
; http://cad-notes.com
;
; Limitation
; ----------
; Will use current leader style and current units setting

(defun c:xy (/ p x y ptcoord textloc)
(while
(setq p (getpoint "\nPick Point: "))
(setq textloc (getpoint "\nPick Label Location: "))
(setq x (rtos (car p)))
(setq y (rtos (cadr p)))
(setq ptcoord (strcat "X= " x "\n" "Y= " y))
(command "_LEADER" p textloc "" ptcoord "")
)
)
(c:xy)

Draw jump arc in intersection of 2 lines

22 Thursday Oct 2015

Posted by danglar71 in Common

≈ Leave a comment

(defun C:jmp(/ *error* ang ans bp1 bp2 elist1 elist2 entlist1 entlist2 gap ip osm nom pe1 pe2 ps1 ps2 sellist sset1 sset2 vflag)
(vl-load-com)
(defun *error* (msg)
(vla-endundomark (vla-get-activedocument
(vlax-get-acad-object))
)
(cond ((or (not msg)
(member msg '("console break" "Function cancelled" "quit / exit abort"))
)
)
((princ (strcat "\nError: " msg)))
)
(setvar "cmdecho" 1)
(if osm
(setvar "osmode" osm)
)
(if nom
(setvar "osmode" nom)
)
(princ)
)
(vla-startundomark (vla-get-activedocument
(vlax-get-acad-object))
)
(setq osm(getvar "OSMODE"))
(setvar "OSMODE" 0)
; (princ "\nZoom objects to be visible on screen: ")
;(command "_.zoom" "w" pause pause)
(setvar "nomutt" 0)
(setq nom (getvar "nomutt"))

(setvar "nomutt" 0)
(princ "\nSelect vertical lines: ")
(setvar "nomutt" 1)
(setq sset1 (ssget ":L" '((0 . "LINE"))))
(setvar "nomutt" 0)
(princ "\nSelect horizontal lines: ")
(setvar "nomutt" 1)
(setq sset2 (ssget ":L" '((0 . "LINE"))))
(setvar "nomutt" 0)
(setq *gap* 1);<-- set your gap between lines here
(setq gap (getdist (strcat "\nSet a gap by 2 points : ")))
(cond ((not gap)(setq gap *gap*)))
(setq entlist1 (vl-remove-if 'listp(mapcar 'cadr (ssnamex sset1)))
entlist2 (vl-remove-if 'listp(mapcar 'cadr (ssnamex sset2))))
(initget 1 "Vertical Horizontal" )
(setq ans (getkword "\nChoose lines to be jumped over [Vertical/Horizontal]:"))
(if (eq ans "Vertical")(setq vflag t)(setq vflag nil))
(if vflag (progn
;;swap references to selected objects :
(setq sellist (list entlist1 entlist2)
entlist2(car sellist)
entlist1(cadr sellist))

(setq ang (/ pi 2))
)
(setq ang 0)
)
(foreach ent1 entlist1
(setq elist1 (entget ent1))
(setq ps1 (cdr (assoc 10 elist1)))
(setq pe1 (cdr (assoc 11 elist1)))
(foreach ent2 entlist2
(setq elist2 (entget ent2))
(setq ps2 (cdr (assoc 10 elist2)))
(setq pe2 (cdr (assoc 11 elist2)))
(setq ip (inters ps2 pe2 ps1 pe1 nil))
(setq ip (vlax-curve-getclosestpointto ent1 ip))
(setq bp1 (polar ip ang (/ gap 2)))
(setq bp2 (polar ip (+ ang pi) (/ gap 2)))

(command "_.break" bp1 bp2)

(command "_.arc" bp1 "_E" bp2 "_A" 180.)

)
)
; (command "_.zoom" "p")
(*error* nil)
(princ)
)
(prompt "\n >>> Type JMP to execute...")
(princ)

(c:jmp)

Change All Vports from Polygonal to Rectangular (Lee Mac Solution for 4 corner viewports.)

21 Wednesday Oct 2015

Posted by danglar71 in Vport

≈ Leave a comment

(defun c:avpr ( / cmd ctb ent enx idx sel )

;Change All Vports from Polygonal to Rectangular (Lee Mac Solution for 4 corner viewports.)

(setq cmd (getvar 'cmdecho)

ctb (getvar 'ctab)

)

(setvar 'cmdecho 0)

(foreach lay (layoutlist)

(setvar 'ctab lay)

(if (setq sel (ssget "_X" (list '(0 . "VIEWPORT") (cons 410 lay))))

(repeat (setq idx (sslength sel))

(setq ent (ssname sel (setq idx (1- idx)))

enx (entget ent)

)

(if (and (< 0 (logand 65536 (cdr (assoc 90 enx))))

(= 4 (cdr (assoc 90 (entget (cdr (assoc 340 enx))))))

)

(command "_.vpclip" ent "_d")

)

)

)

)

(setvar 'ctab ctb)

(setvar 'cmdecho cmd)

(princ)

)

(c:avpr)

Draw Leader as Polyline

20 Tuesday Oct 2015

Posted by danglar71 in Common

≈ Leave a comment

(defun c:p2l (/ e o ss i sn l p)
;; Based on Tharwat routine 17.10.2015 ;; Recreated by Igal Averbuh 20.10.2015

(and (or (= (getvar "_VERNUM") "G.55.0.0 (UNICODE)");;;2013 without service packs
(= (getvar "_VERNUM") "G.204.0.0 (UNICODE)");2013 SP2
(= (getvar "_VERNUM") "G.114.0.0 (UNICODE)");2013 SP1.1
(= (getvar "_VERNUM") "G.112.0.0 (UNICODE)");2013 SP1

)
)

(acet-ql-set '((60 . 4)(65 . 0)(66 . 0)(67 . 3)(70 . 0)(71 . 0)))

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

(if (setq e (entlast)
ss (ssget "_:L" '((0 . "LWPOLYLINE") (-4 . "=") (90 . 3)))
)
(repeat (setq i (sslength ss))
(setq sn (ssname ss (setq i (1- i)))
l (mapcar
'cdr
(vl-remove-if-not '(lambda (p) (eq (car p) 10)) (entget sn))
)
)
(if (> (distance (car l) (cadr l))
(distance (caddr l) (cadr l))
)
(setq p (reverse l))
(setq p l)
)
(setvar "cmdecho" 0)
(command "_.qleader"
"_none"
(car p)
"_none"
(cadr p)
"_none"
(caddr p)

)
(if (not (eq e (setq o (entlast))))
(progn
(entdel sn)
(setq e o)
)
)
)
)
(princ)
(setvar "cmdecho" 1)
)

;;
;; 2.19.2002 Rob Tomson
;; (acet-ql-get)
;; Returns an association list containing the current QLEADER
;; settings from the Named Object Dictionary.
;;
;; (acet-ql-get )
;; Sets the specified values for QLEADER settings from the given
;; association list. Returns an association list containing the
;; new values.
;;
;; These functions can be used to examine the current QLEADER
;; settings, or to initialize the setting before using the QLEADER
;; command. For example, to use splined leaders and framed text:
;;
;; (acet-ql-set '((65 . 1)(72 . 1)))
;;
;; Both functions use the following group codes to identify QLEADER
;; settings:
;;
;; 3: user arrowhead block name (default="")
;; 40: default text width (default=0.0)
;; 60: annotation type (default=0)
;; 0=MText
;; 1=copy object
;; 2=Tolerance
;; 3=block
;; 4=none
;; 61: annotation reuse (default=0)
;; 0=none
;; 1=reuse next
;; 62: left attachment point (default=1)
;; 63: right attachment point (default=3)
;; 0=Top of top line
;; 1=Middle of top line
;; 2=Middle of multiline text
;; 3=Middle of bottom line
;; 4=Bottom of bottom line
;; 64: underline bottom line (default=0)
;; 65: use splined leader line (default=0)
;; 66: no limit on points (default=0)
;; 67: maximum number of points (default=3)
;; 68: prompt for MText width (word wrap) (default=1)
;; 69: always left justify (default=0)
;; 70: allowed angle, first segment (default=0)
;; 71: allowed angle, second segment (default=0)
;; 0=Any angle
;; 1=Horizontal
;; 2=90deg
;; 3=45deg
;; 4=30deg
;; 5=15deg
;; 72: frame text (default=0)
;; 170: active tab (default=0)
;; 0=Annotation
;; 1=Leader Line & Arrow
;; 2=Attachment
;; 340: object ID for annotation reuse
;;
(defun acet-ql-get (/ xr cod itm reply)
(if (setq xr (dictsearch (namedobjdict) "AcadDim_CRX"))
(progn
(foreach cod
'(3 40 60 61 62 63 64 65 66 67 68 69 70 71 72 170 340)
(if (setq itm (assoc cod xr))
(setq reply (append reply (list itm)))
)
)
reply
)
'((3 . "")
(40 . 0.0)
(60 . 4)
(61 . 0)
(62 . 1)
(63 . 1)
(64 . 0)
(65 . 0)
(66 . 0)
(67 . 3)
(68 . 0)
(69 . 0)
(70 . 3)
(71 . 2)
(72 . 0)
(170 . 0)
)
)
)
(defun acet-ql-set (arg / cur prm)
(setq cur (acet-ql-get))
(while arg
(setq prm (car arg)
arg (cdr arg)
cur (subst prm (assoc (car prm) cur) cur)
)
(if (= 3 (car prm))
(setvar "DIMLDRBLK" (cdr prm))
)
)
(dictremove (namedobjdict) "AcadDim_CRX")
(setq
cur (append '((0 . "XRECORD") (100 . "AcDbXrecord") (90 . 990106))
cur
)
)
(dictadd (namedobjdict) "AcadDim_CRX" (entmakex cur))
(acet-ql-get)
)
(princ)

(acet-ql-set
'((3 . "")
(40 . 0.0)
(60 . 4)
(61 . 0)
(62 . 1)
(63 . 1)
(64 . 0)
(65 . 0)
(66 . 0)
(67 . 3)
(68 . 0)
(69 . 0)
(70 . 3)
(71 . 2)
(72 . 1)
(170 . 0)
)
)
;;
(defun c:dlp ()
(command "pline")
(while (> (getvar "CmdActive") 0)
(command pause)
)
(c:p2l)
)
(c:dlp)

Convert Polylines to Leaders in one Click

20 Tuesday Oct 2015

Posted by danglar71 in Common

≈ 3 Comments


(defun c:p2l (/ e o ss i sn l p)
;; Created by Tharwat 17.10.2015
;; Modified by Igal Averbuh 20.10.2015

(and (or (= (getvar "_VERNUM") "G.55.0.0 (UNICODE)");;;2013 without service packs
(= (getvar "_VERNUM") "G.204.0.0 (UNICODE)");2013 SP2
(= (getvar "_VERNUM") "G.114.0.0 (UNICODE)");2013 SP1.1
(= (getvar "_VERNUM") "G.112.0.0 (UNICODE)");2013 SP1

)
)

(acet-ql-set '((60 . 4)(65 . 0)(66 . 0)(67 . 3)(70 . 0)(71 . 0)))

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

(if (setq e (entlast)
ss (ssget "_:L" '((0 . "LWPOLYLINE") (-4 . "=") (90 . 3)))
)
(repeat (setq i (sslength ss))
(setq sn (ssname ss (setq i (1- i)))
l (mapcar
'cdr
(vl-remove-if-not '(lambda (p) (eq (car p) 10)) (entget sn))
)
)
(if (> (distance (car l) (cadr l))
(distance (caddr l) (cadr l))
)
(setq p (reverse l))
(setq p l)
)
(setvar "cmdecho" 0)
(command "_.qleader"
"_none"
(car p)
"_none"
(cadr p)
"_none"
(caddr p)

)
(if (not (eq e (setq o (entlast))))
(progn
(entdel sn)
(setq e o)
)
)
)
)
(princ)
(setvar "cmdecho" 1)
)

;;
;; 2.19.2002 Rob Tomson
;; (acet-ql-get)
;; Returns an association list containing the current QLEADER
;; settings from the Named Object Dictionary.
;;
;; (acet-ql-get )
;; Sets the specified values for QLEADER settings from the given
;; association list. Returns an association list containing the
;; new values.
;;
;; These functions can be used to examine the current QLEADER
;; settings, or to initialize the setting before using the QLEADER
;; command. For example, to use splined leaders and framed text:
;;
;; (acet-ql-set '((65 . 1)(72 . 1)))
;;
;; Both functions use the following group codes to identify QLEADER
;; settings:
;;
;; 3: user arrowhead block name (default="")
;; 40: default text width (default=0.0)
;; 60: annotation type (default=0)
;; 0=MText
;; 1=copy object
;; 2=Tolerance
;; 3=block
;; 4=none
;; 61: annotation reuse (default=0)
;; 0=none
;; 1=reuse next
;; 62: left attachment point (default=1)
;; 63: right attachment point (default=3)
;; 0=Top of top line
;; 1=Middle of top line
;; 2=Middle of multiline text
;; 3=Middle of bottom line
;; 4=Bottom of bottom line
;; 64: underline bottom line (default=0)
;; 65: use splined leader line (default=0)
;; 66: no limit on points (default=0)
;; 67: maximum number of points (default=3)
;; 68: prompt for MText width (word wrap) (default=1)
;; 69: always left justify (default=0)
;; 70: allowed angle, first segment (default=0)
;; 71: allowed angle, second segment (default=0)
;; 0=Any angle
;; 1=Horizontal
;; 2=90deg
;; 3=45deg
;; 4=30deg
;; 5=15deg
;; 72: frame text (default=0)
;; 170: active tab (default=0)
;; 0=Annotation
;; 1=Leader Line & Arrow
;; 2=Attachment
;; 340: object ID for annotation reuse
;;
(defun acet-ql-get (/ xr cod itm reply)
(if (setq xr (dictsearch (namedobjdict) "AcadDim_CRX"))
(progn
(foreach cod
'(3 40 60 61 62 63 64 65 66 67 68 69 70 71 72 170 340)
(if (setq itm (assoc cod xr))
(setq reply (append reply (list itm)))
)
)
reply
)
'((3 . "")
(40 . 0.0)
(60 . 4)
(61 . 0)
(62 . 1)
(63 . 1)
(64 . 0)
(65 . 0)
(66 . 0)
(67 . 3)
(68 . 0)
(69 . 0)
(70 . 3)
(71 . 2)
(72 . 0)
(170 . 0)
)
)
)
(defun acet-ql-set (arg / cur prm)
(setq cur (acet-ql-get))
(while arg
(setq prm (car arg)
arg (cdr arg)
cur (subst prm (assoc (car prm) cur) cur)
)
(if (= 3 (car prm))
(setvar "DIMLDRBLK" (cdr prm))
)
)
(dictremove (namedobjdict) "AcadDim_CRX")
(setq
cur (append '((0 . "XRECORD") (100 . "AcDbXrecord") (90 . 990106))
cur
)
)
(dictadd (namedobjdict) "AcadDim_CRX" (entmakex cur))
(acet-ql-get)
)
(princ)

(acet-ql-set
'((3 . "")
(40 . 0.0)
(60 . 4)
(61 . 0)
(62 . 1)
(63 . 1)
(64 . 0)
(65 . 0)
(66 . 0)
(67 . 3)
(68 . 0)
(69 . 0)
(70 . 3)
(71 . 2)
(72 . 1)
(170 . 0)
)
)
;;
(c:p2l)

Convert All Vports in All Layouts from Polygonal to Rectangular

19 Monday Oct 2015

Posted by danglar71 in Vport

≈ Leave a comment

(defun c:avpr (/ *error* acdoc cmd ss i e)
(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
cmd (getvar 'cmdecho))
(vla-startundomark acdoc)
(setvar 'cmdecho 0)

(defun *error* (msg)
(and
msg
(not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(setvar 'cmdecho cmd)
(vla-endundomark acdoc)
(princ)
)

(foreach lo (layoutlist)
(setvar 'ctab lo)
(vla-put-mspace acdoc :vlax-false)
(if
(setq ss (ssget "_X" (list '(0 . "VIEWPORT") (cons 410 lo) '(-4 . ">") '(68 . 1))))
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i))))
(if
(= (logand 65536 (cdr (assoc 90 (entget e)))) 65536); or (assoc 340 (entget e)) ??? -> clipped viewport
(command "_clip" e "_d")
)
)
)
)

(*error* nil)
(princ)
)
(c:avpr)

Convert Single Vport from Polygonal to Rectangular

19 Monday Oct 2015

Posted by danglar71 in Vport

≈ Leave a comment

(defun c:vpr ()
(setvar "cmdecho" 0)
(setq switch (command "_.pspace"))
(setq selections (entsel "Select Polygonal VPort to convert to Rectangular: "))
(command "vpclip" selections "d" )
)

Select similar blocks which have different names

18 Sunday Oct 2015

Posted by danglar71 in Blocks

≈ Leave a comment

;; Select similar blocks which have different names - Lee Mac

(defun c:ssb ( / blk def ent lst tmp )

(while

(progn (setvar 'errno 0) (setq blk (car (entsel "\nSelect block: ")))

(cond

( (= 7 (getvar 'errno))

(princ "\nMissed, try again.")

)

( (null blk) nil)

( (/= "INSERT" (cdr (assoc 0 (setq blk (entget blk)))))

(princ "\nSelected object is not a block.")

)

)

)

)

(if blk

(progn

(while (setq def (tblnext "block" (null def)))

(setq ent (tblobjname "block" (cdr (assoc 2 def)))

tmp nil

)

(while (setq ent (entnext ent))

(setq tmp

(append tmp

(vl-remove-if

'(lambda ( x ) (or (= 'ename (type (cdr x))) (member (car x) '(5))))

(entget ent)

)

)

)

)

(setq lst

(cons

(cons (assoc 2 def)

(vl-sort tmp

'(lambda ( a b )

(if (= (car a) (car b))

(if (listp (cdr a)) (vl-some '< (cdr a) (cdr b)) (< (cdr a) (cdr b)))

(< (car a) (car b))

)

)

)

)

lst

)

)

)

(setq blk (cdr (assoc (assoc 2 blk) lst)))

(sssetfirst nil

(ssget "_X"

(append '((0 . "INSERT") (-4 . ""))

)

)

)

)

)

(princ)

)

;; Escape Wildcards - Lee Mac

;; Escapes wildcard special characters in a supplied string

(defun LM:escapewildcards ( str )

(vl-list->string

(apply 'append

(mapcar

'(lambda ( c )

(if (member c '(35 64 46 42 63 126 91 93 45 44))

(list 96 c)

(list c)

)

)

(vl-string->list str)

)

)

)

)

(princ)

(c:ssb)

← Older posts

Recent Posts

  • Это наша плата за трусость
  • Set the Default Application to open DWG Files
  • Draw “Heat Grid” (Lee Mac)
  • PROGRAM FOR SPRINKLER DISTRIBUTION
  • How to remove Frames around blocks

Recent Comments

Wilmer Lacayo on Draw Centroid (center of gravi…
Jun on Convert Polylines to Leaders i…
Adel on HVAC Draw Branch Duct
danglar71 on Draw “Heat Grid” (…
IOAN VLAD on Draw “Heat Grid” (…

Archives

  • January 2021
  • March 2020
  • February 2020
  • January 2020
  • October 2019
  • September 2019
  • August 2019
  • July 2019
  • June 2019
  • May 2019
  • April 2019
  • February 2019
  • January 2019
  • December 2018
  • November 2018
  • October 2018
  • September 2018
  • August 2018
  • July 2018
  • June 2018
  • April 2018
  • March 2018
  • February 2018
  • January 2018
  • December 2017
  • November 2017
  • August 2017
  • July 2017
  • June 2017
  • May 2017
  • April 2017
  • March 2017
  • February 2017
  • January 2017
  • December 2016
  • November 2016
  • October 2016
  • September 2016
  • August 2016
  • July 2016
  • June 2016
  • May 2016
  • April 2016
  • March 2016
  • February 2016
  • January 2016
  • December 2015
  • November 2015
  • October 2015
  • September 2015
  • August 2015
  • July 2015
  • June 2015
  • May 2015
  • April 2015
  • March 2015
  • February 2015
  • January 2015
  • December 2014
  • November 2014

Categories

  • 3D
  • Annonymous Blocks
  • Attribute
  • Batch
  • Blocks
  • Books
  • Common
  • Coordinates
  • Counting
  • dimmensions
  • draw
  • Export
  • Fractal
  • Hatch
  • HVAC
  • Images
  • Import
  • Info
  • Isometric
  • Layers
  • Layouts
  • Lisp Collection 2014
  • Mline
  • Pdf
  • Pipes
  • plot
  • Points
  • Protect
  • Text
  • Tips (English)
  • Tips (Russian)
  • ucs
  • Utilites
  • view
  • Vport
  • Xref

Recent Posts

  • Это наша плата за трусость
  • Set the Default Application to open DWG Files
  • Draw “Heat Grid” (Lee Mac)
  • PROGRAM FOR SPRINKLER DISTRIBUTION
  • How to remove Frames around blocks

Recent Comments

Wilmer Lacayo on Draw Centroid (center of gravi…
Jun on Convert Polylines to Leaders i…
Adel on HVAC Draw Branch Duct
danglar71 on Draw “Heat Grid” (…
IOAN VLAD on Draw “Heat Grid” (…

Archives

  • January 2021
  • March 2020
  • February 2020
  • January 2020
  • October 2019
  • September 2019
  • August 2019
  • July 2019
  • June 2019
  • May 2019
  • April 2019
  • February 2019
  • January 2019
  • December 2018
  • November 2018
  • October 2018
  • September 2018
  • August 2018
  • July 2018
  • June 2018
  • April 2018
  • March 2018
  • February 2018
  • January 2018
  • December 2017
  • November 2017
  • August 2017
  • July 2017
  • June 2017
  • May 2017
  • April 2017
  • March 2017
  • February 2017
  • January 2017
  • December 2016
  • November 2016
  • October 2016
  • September 2016
  • August 2016
  • July 2016
  • June 2016
  • May 2016
  • April 2016
  • March 2016
  • February 2016
  • January 2016
  • December 2015
  • November 2015
  • October 2015
  • September 2015
  • August 2015
  • July 2015
  • June 2015
  • May 2015
  • April 2015
  • March 2015
  • February 2015
  • January 2015
  • December 2014
  • November 2014

Categories

  • 3D
  • Annonymous Blocks
  • Attribute
  • Batch
  • Blocks
  • Books
  • Common
  • Coordinates
  • Counting
  • dimmensions
  • draw
  • Export
  • Fractal
  • Hatch
  • HVAC
  • Images
  • Import
  • Info
  • Isometric
  • Layers
  • Layouts
  • Lisp Collection 2014
  • Mline
  • Pdf
  • Pipes
  • plot
  • Points
  • Protect
  • Text
  • Tips (English)
  • Tips (Russian)
  • ucs
  • Utilites
  • view
  • Vport
  • Xref

Blog at WordPress.com.

Privacy & Cookies: This site uses cookies. By continuing to use this website, you agree to their use.
To find out more, including how to control cookies, see here: Cookie Policy