Mark Mid Point

October 26, 2018

Hello,

I found a lisp on the web that puts blocks on a selected polyline.

I use a script for running that script.

Works ok.........but,......

And this give me the result A (see dwg),

the question is, can it be modified to get it like in B (see mark circles in dwg)?

script:

mmp
blocks
"TAG"
1
Relative
0

A
Last

MarkMidPoints.lsp

;;  MarkMidPoints.lsp [command name: MMP]
;;  Kent Cooper, December 2011
;;  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.
;
(vl-load-com)
;
(defun C:MMP ; = Mark Mid-Points
  (/ *error* mmp-dir mmp-reset osm cmde blips clay blktemp scltemp rotdef rottemp
  laydef laytemp pathsel path pathdata pathtype pathextr ucschanged par mmp-pt)
    ; add pdm & pds if used
;
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    ); if
    (command)
    (if ucschanged (command "_.ucs" "_prev"))
      ;; ^ don't go back unless routine reached UCS change but didn't change it back
    (command "_.undo" "_end")
    (mmp-reset)
  ); 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
;
  (defun mmp-reset ()
    (setvar 'clayer clay)
    (setvar 'osmode osm)
    (setvar 'blipmode blips)
; pdmode/pdsize reset possibility -- not included so Points remain visible
;    (setvar 'pdmode pdm)
;    (setvar 'pdsize pds)
    (setvar 'cmdecho cmde)
    (princ)
  ); defun - mmp-reset
;
  (setq
    osm (getvar 'osmode)
    cmde (getvar 'cmdecho)
    blips (getvar 'blipmode)
; pdmode/pdsize saving possibility -- not included so Points remain visible
;    pdm (getvar 'pdmode)
;    pds (getvar 'pdsize)
  ); setq
  (setvar 'cmdecho 0)
  (setq clay (getvar 'clayer))
;
  (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
      ("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
      ("All"); default on first use
    ); cond
  ); setq
;
  (while
    (and
      (not ; T when (while) below is satisfied
        (while
          (not
            (and
              (not ; T when (while) below is satisfied
                (while
                  (and
                    (not (setq pathsel (entsel "\nSelect object to Mark Mid-Point(s) on: ")))
                    (= (getvar 'errno) 7)
                  ); and
                  (prompt "\nNothing selected -- try again.")
                ); end while
              ); not
              (if pathsel
                (wcmatch ; then
                  (cdr (assoc 0 (entget (car pathsel))))
                  "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE" ; omit Circle if desired, check for closed Ellipse/Spline?
                ); wcmatch
                T ; else - Enter/space for (entsel) above
              ); if
            ); and
          ); not
          (prompt "\nInvalid object type.")
        ); while
      ); not
      pathsel ; something selected - lets Enter/space end routine
    ); and
;
    (command "_.undo" "_begin")
    (setq
      path (car pathsel)
      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
;
    (setvar 'osmode 0)
    (setvar 'blipmode 0)
    (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
    (command "_.undo" "_end")
  ); while
  (mmp-reset)
); defun - MMP
;
(prompt "Type MMP to Mark the Mid-Points of selected objects.")

Thank you very much, already

PmxCAD

Test-MMP.dwg

October 27, 2018

Insert this instead (mmp-dir) sub function :

;
;|
  (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
|;
;
  (defun mmp-dir ( / a ) ; local DIRection [radians] of path at mmp-pt location
    (cond
      ( (equal 0.0
        (setq a
          (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
        ); setq
        1e-6)
        a
      )
      ( (< 0.0 a (* pi 0.5))
        a
      )
      ( (equal (* pi 0.5) a 1e-6)
        a
      )
      ( (< (* pi 0.5) a pi)
        (+ a pi)
      )
      ( (equal pi a 1e-6)
        (- a pi)
      )
      ( (< pi a (* pi 1.5))
        (- a pi)
      )
      ( (equal (* pi 1.5) a 1e-6)
        (- a pi)
      )
      ( (< (* pi 1.5) a (* pi 2.0))
        a
      )
      ( (equal (* pi 2.0) a 1e-6)
        (- a pi pi)
      )
    ); cond
  ); defun - mmp-dir
;

M.R.

October 27, 2018

Actually, if you have to insert all the same attribute specification : "R1.5", use this attached mod... Note that you should change only line 420 if you have new requirement...

HTH., M.R. Also your *.scr file should end with ENTER after "Last", but you already know that...

MarkMidPoints.lsp

October 27, 2018

11 hours ago, marko_ribar said:

Insert this instead (mmp-dir) sub function :


;
;|
  (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
|;
;
  (defun mmp-dir ( / a ) ; local DIRection [radians] of path at mmp-pt location
    (cond
      ( (equal 0.0
        (setq a
          (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
        ); setq
        1e-6)
        a
      )
      ( (< 0.0 a (* pi 0.5))
        a
      )
      ( (equal (* pi 0.5) a 1e-6)
        a
      )
      ( (< (* pi 0.5) a pi)
        (+ a pi)
      )
      ( (equal pi a 1e-6)
        (- a pi)
      )
      ( (< pi a (* pi 1.5))
        (- a pi)
      )
      ( (equal (* pi 1.5) a 1e-6)
        (- a pi)
      )
      ( (< (* pi 1.5) a (* pi 2.0))
        a
      )
      ( (equal (* pi 2.0) a 1e-6)
        (- a pi pi)
      )
    ); cond
  ); defun - mmp-dir
;

M.R.

M.R. works superrrrrrr...... Thanks

October 27, 2018

M.R. works superrrrrrr...... Thanks

October 27, 2018

Marko, yours is slower and gives an error like:

Unknown command "MMP". Press F1 for help.
Unknown command "5". Press F1 for help.
Unknown command "MMP". Press F1 for help.
Unknown command "5". Press F1 for help.
Unknown command "MMP". Press F1 for help.
Unknown command "5". Press F1 for help.
Unknown command "MMP". Press F1 for help.
Unknown command "5". Press F1 for help.
Unknown command "MMP". Press F1 for help.
Unknown command "5". Press F1 for help.
Unknown command "MMP". Press F1 for help.
Unknown command "5". Press F1 for help.
Unknown command "MMP". Press F1 for help.
Unknown command "5". Press F1 for help.
Unknown command "MMP". Press F1 for help.
Unknown command "5". Press F1 for help.
Unknown command "MMP". Press F1 for help.
Unknown command "5". Press F1 for help.
Unknown command "MMP". Press F1 for help.

Edited October 27, 2018 by pmxcad

Sign In

Mark Mid Point

Recommended Posts

pmxcad

marko_ribar

marko_ribar

pmxcad

pmxcad

pmxcad

Join the conversation

Tutorials

Forums

Activity