Message 1 of 8
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
A time ago I found a beautiful lisp (attached), but I need a hero to modify this lisp to insert ATTRIBUTE, TEXT, MTEXT, RTEXT, DTEXT with the same method.
;| MarkMidPoints.lsp [command name: MMP]
To MARK the MIDPOINT(S) of selected object(s), with Points, Blocks, or Lines.
Points option: sets PDMODE and PDSIZE to make Points visible.
Blocks option: any Block in drawing or drawing in Support File path list, any
scale, any rotation including Aligned-with-object and Relative-to-object options.
Lines option: perpendicular at midpoint(s); User specifies length of Lines.
For Polylines, option to mark midpoints of all segments, or only overall midpoint.
Kent Cooper, last edited 8 May 2018 [multiple-object selection]
|;
(vl-load-com)
(defun C:MMP ; = Mark Mid-Points
(/ *error* mmp-dir svnames svvals blktemp scltemp rotdef rottemp laydef
laytemp pathsel doc path pathdata pathtype pathextr ucschanged par mmp-pt)
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); if
(if ucschanged (command-s "_.ucs" "_prev"));; [remove -s for pre-2015 version]
;; ^ don't go back unless routine reached UCS change but didn't change it back
(vla-endundomark doc)
(mapcar 'setvar svnames svvals); reset
(princ)
); defun - *error*
(defun mmp-dir () ; local DIRection [radians] of path at mmp-pt location
(angle
'(0 0 0)
(trans
(vlax-curve-getFirstDeriv
path
(vlax-curve-getParamAtPoint path (trans mmp-pt 1 0))
); getFirstDeriv
0 1 T ; world to current CS, as displacement
); trans
); angle
); defun - mmp-dir
(prompt "\nTo Mark Mid-Points,")
(if (setq ss (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))))
(progn ; then
(setq
svnames '(osmode blipmode ucsfollow cmdecho clayer)
;;; pdmode/pdsize saving possibility -- not included so Points
;;; remain visible after use; add to svnames list if desired
svvals (mapcar 'getvar svnames)
); setq
(vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
(setvar 'cmdecho 0)
(initget "Blocks Points Lines")
(setq _mmp-type_
(cond
( ; User entry
(getkword
(strcat
"\nMark with Points/Blocks/Lines? <"
(substr (cond (_mmp-type_) ("Points")) 1 1)
">: "
); strcat
); getkword
); User entry condition
(_mmp-type_); existing default if present on Enter
("Points"); default on first use
); cond
); setq
(cond
((= _mmp-type_ "Blocks")
(while
(cond
((not blktemp)); none yet [first time through (while) loop]
((and (= blktemp "") (= (getvar 'insname) "")))
; User hit Enter, but no MMP or Insert defaults
((and
(/= blktemp ""); User typed something, but
(not (tblsearch "block" blktemp)); no such Block in drawing
(not (findfile (strcat blktemp ".dwg"))); no such drawing in Search paths
); and
); condition
); cond
(setq blktemp
(getstring
(strcat
"\nBlock to insert to Mark Mid-Point(s) on path(s)"
(cond
(_mmp-blk_ (strcat " <" _mmp-blk_ ">")); prior Block used, if any
((/= (getvar 'insname) "") (strcat " <" (getvar 'insname) ">")); offer Insert's default, if any
(T ""); no default offered on first use if no MMP or Insert defaults
); cond
": "
); strcat
); getstring and blktemp
); setq
); while
(setq _mmp-blk_
(cond
((/= blktemp "") blktemp); User typed something
(_mmp-blk_); default, if any
((getvar 'insname)); Enter on first use with Insert default
); cond
); set
(initget 134 "Graphic")
(setq scltemp
(getkword ; [returns nil on Enter]
(strcat
"\nScale for Blocks, or Graphic for symbol scaled to drawing <"
(cond
((= _mmp-scl_ (getvar 'dimscale)) (strcat (rtos _mmp-scl_ 2 4) "= Graphic scale"))
(_mmp-scl_ (rtos _mmp-scl_ 2 4))
(T "1"); default on first use
); cond
">: "
); strcat
); getkword and scltemp
); setq
(setq _mmp-scl_
(cond
((= scltemp "Graphic") (getvar 'dimscale)); User chose Graphic; get drawing scale
((and scltemp (/= (atof scltemp) 0)) (atof scltemp)); User typed numerical string; convert to number
(T (cond (_mmp-scl_) (T 1))); User hit Enter and there's a default, then - use it; else - 1 [first use]
); cond and scale
); set
(initget 32 "Aligned Relative"); dashed rubber-band if picked on-screen
(setq
rotdef (cond (_mmp-rot_) (T "Aligned")); Aligned default on first use
rottemp
(getangle
(strcat
"\nBlock rotation, or Aligned with path or Relative angle to path [angle/A/R] <"
(if (numberp rotdef); if default is a number,
(angtos rotdef); then - text, current angle units
(substr rotdef 1 1) ; else - "A" or "R"
); if
">: "
); strcat
); getangle and rottemp
); setq
(setq _mmp-rot_
(cond
((numberp rottemp) rottemp)
; User typed number
(rottemp); User typed A or R
(rotdef); otherwise, User hit Enter -- use default
); cond and rot variable
); set
(if (= _mmp-rot_ "Relative")
(progn
(initget 36)
; no negative, dashed rubber-band if picked on-screen
(setq _mmp-rel_
(cond
( ; User input
(getangle
(strcat
"\nAngle of Blocks Relative to path direction <"
(if _mmp-rel_ (angtos _mmp-rel_) "0"); designate units/precision if desired
">: "
); strcat
); getangle & reltemp
); User input condition
(_mmp-rel_); existing default if present
(0); 0 default on first use
); cond
); setq
); progn
); if
); Blocks condition
((= _mmp-type_ "Lines")
(if _mmp-lin_
(initget 6); then - no zero, no negative
(initget 7); else - no zero, no negative, no Enter on first use
); end if
(setq _mmp-lin_
(cond
( ; User input
(getdist ; [returns nil on Enter]
(strcat
"\nEnter length of marking Lines"
(if _mmp-lin_ (strcat " <" (rtos _mmp-lin_) ">") ""); default if present
": "
); end strcat
); end getdist and lintemp
); User input condition
(_mmp-lin_); default
); cond
); end setq
); Lines condition
(T (setvar 'pdmode 35) (setvar 'pdsize -3)); Points - change values as desired
); cond - Blocks or Lines or Points
(setq laydef (cond (_mmp-lay_) ("Current"))); current-Layer first-use default
(initget 128 "Current Same"); allow Enter or non-keyword input
(while
(and
(setq laytemp
(getkword ; User input other than Enter,
(strcat
"\nLayer for "
_mmp-type_
", or Current, or Same as selected path <"
laydef
">: "
); strcat
); getkword and laytemp
); setq
(not (wcmatch laytemp "Current,Same")); and it wasn't C or S,
(not (tblsearch "layer" laytemp)); and Layer is not in the drawing
); and
(initget 128 "Current Same")
(prompt "\nLayer does not exist in this drawing--")
;;;; [add option to Make it?]
); while
(setq _mmp-lay_ (cond (laytemp) (T laydef)))
; User input [including C or S], then - use it; else - default
(if (not (wcmatch _mmp-lay_ "Current,Same"))
; if it's a Layer name that does exist, not current nor the object's,
(command "_.layer" "_thaw" _mmp-lay_ ""); then - ensure it's Thawed; set current later
); if
(initget "All Overall")
(setq _mmp-plseg_
(cond
( ; User entry
(getkword
(strcat
"\nOn Polyline, mark All segments or Overall midpoint [A/O]? <"
(substr (cond (_mmp-plseg_) ("All")) 1 1)
">: "
); strcat
); getkword
); User entry condition
(_mmp-plseg_); existing default if present on Enter
("All"); default on first use
); cond
); setq
(mapcar 'setvar svnames '(0 0 0)); osnap, blips, ucsfollow off
(repeat (setq n (sslength ss)); then
(setq
path (ssname ss (setq n (1- n)))
pathdata (entget path)
pathtype (cdr (assoc 0 pathdata))
pathtype
(if (wcmatch pathtype "POLYLINE")
(strcase (substr (cdr (assoc 100 (cdr (member (assoc 100 pathdata) 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"); omit Circle if desired
(not (equal (trans pathextr 0 1) '(0 0 1) 1e-12)); 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")
(command "_.ucs" "_new" "_object" path); set UCS to match object
); if
(setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't get to it
); progn
); if - UCS match object
(if (/= _mmp-lay_ "Current"); set Layer only if Current not selected
(command "_.layer" "_set" ; [this instead of (setvar 'clayer) will turn it on if it's off]
(if (= _mmp-lay_ "Same")
(cdr (assoc 8 pathdata)); then - get layer of object
_mmp-lay_ ; else - use specified Layer
); if
""
); command - Layer
); if - not Current Layer
(setq par -0.5)
(repeat
(if (and (wcmatch pathtype "*POLYLINE") (= _mmp-plseg_ "All"))
(fix (vlax-curve-getEndParam path)); then
1 ; else - other object types
); if
(setq mmp-pt
(trans
(if (and (wcmatch pathtype "*POLYLINE") (= _mmp-plseg_ "All"))
(vlax-curve-getPointAtParam path (setq par (1+ par))); then
(vlax-curve-getPointAtDist ; else - midway along length
path
(/
(vlax-curve-getDistAtParam path (vlax-curve-getEndParam path)); overall length
2
); /
); getPointAtDist
); if
0 1
); trans and mmp-pt
); setq
(cond
((= _mmp-type_ "Points") (command "_.point" mmp-pt))
((= _mmp-type_ "Blocks")
(command
"_.insert" _mmp-blk_
"_scale" _mmp-scl_
mmp-pt ; insertion point
(cond ; rotation
((= _mmp-rot_ "Aligned") (angtos (mmp-dir))); local direction
((= _mmp-rot_ "Relative") (angtos (+ (mmp-dir) _mmp-rel_))); local direction + relative angle
((angtos _mmp-rot_)) ; otherwise - specified constant angle
); cond - rotation
); command
); Blocks condition
(T ; [Lines]
(command
"_.line"
(polar
mmp-pt
(+ (mmp-dir) (/ pi 2))
(/ _mmp-lin_ 2)
); polar
(polar
mmp-pt
(- (mmp-dir) (/ pi 2))
(/ _mmp-lin_ 2)
); polar
""
); command
); none-of-the-above [Lines] condition
); cond
); repeat
(if ucschanged (command "_.ucs" "_prev"))
(setq ucschanged nil); eliminate UCS reset in *error* since routine did it already
); repeat
); progn
); if
(vla-endundomark doc)
(mapcar 'setvar svnames svvals); reset
(princ)
); defun - MMP
(prompt "Type MMP to Mark the Mid-Points of selected object(s).")
Solved! Go to Solution.
