Block align to end pline (s) multiples

[Edwin.Saez]

Hi

I come to your great help: oops: so I can Provide some lisp routine for the following:

* I want to place a block That multiply at the ends of Several polylines, perpendicular and Placing them to leave the color, and the layer of each polyline are Selecting.
I Explained in the best dwg I'm attached.

[marko_ribar]

Here, I've created my version based on Kent's routine - the difference is that you can't miss selection through gaps of not continuous linetypes - it uses temporary creation of helper SPLINE entity, but please read alert message and setup your DWG before processing according to message that pops up...

(defun C:ATapaEnds ( / *error* *adoc* osz cmde ss i spl ent scf bn pt start end dist inspt rotpt )

  (vl-load-com)

  (defun *error* ( m )
    (if osz
      (setvar 'osnapz osz)
    )
    (if cmde
      (setvar 'cmdecho cmde)
    )
    (if (not (vlax-erased-p spl))
      (entdel spl)
    )
    (vla-endundomark *adoc*)
    (if m
      (prompt m)
    )
    (princ)
  )

  (vla-endundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (vla-startundomark *adoc*)
  (alert "Check if reference open 2D curves lie in UCS 0.0 elevation... Restart routine when checked...")
  (if (setq ss (ssget "_A" '((0 . "*POLYLINE,ELLIPSE,ARC,SPLINE,LINE,HELIX"))))
    (progn
      (setq osz (getvar 'osnapz))
      (setvar 'osnapz 1)
      (setq cmde (getvar 'cmdecho))
      (setvar 'cmdecho 1)
      (prompt "\nCreate temporary helper crossing/fence SPLINE 2D entity that crosses 2D curve entities ONLY ONCE!!!...")
      (command "_.spline")
      (while (< 0 (getvar 'cmdactive))
        (command "\\")
      )
      (setq spl (entlast))
      (setq bn (getstring "\nSpecify block name for insertion process <A-tapa> : "))
      (if (= bn "")
        (setq bn "A-tapa")
      )
      (while (not (tblsearch "BLOCK" bn))
        (prompt "\nSpecified block name don't exist in DWG database, please specify another name...")
        (initget 1)
        (setq bn (getstring "\nSpecify block name for insertion process : "))
      )
      (initget 3)
      (setq scf (getreal "\nSpecify scale factor for block insertions : "))
      (repeat (setq i (sslength ss))
        (setq
          ent (ssname ss (setq i (1- i))); the 2D curve from selection set
          pt (vlax-invoke (vlax-ename->vla-object spl) 'intersectwith (vlax-ename->vla-object ent) acextendnone)
          start (vlax-curve-getStartPoint ent)
          end (vlax-curve-getEndPoint ent)
        ); setq
        (if (and pt (setq dist (vlax-curve-getDistAtPoint ent pt)))
          (progn
            (if (> (- (vlax-curve-getDistAtPoint ent end) dist) dist)
              ; Fence-crossing point closer to start than end
              (setq ; then
                inspt (vlax-curve-getStartPoint ent)
                rotpt (polar inspt (angle '(0.0 0.0) (vlax-curve-getFirstDeriv ent (vlax-curve-getStartParam ent))) 1.0)
              ); setq
              (setq ; else [closer to end]
                inspt (vlax-curve-getEndPoint ent)
                rotpt (polar inspt (angle '(0.0 0.0) (vlax-curve-getFirstDeriv ent (vlax-curve-getStartParam ent))) -1.0)
              ); setq
            ); if
            (command "_.insert" bn "_scale" scf "_none" inspt rotpt)
            (command "_.change" (entlast) "" "_p" "_la" (vla-get-layer (vlax-ename->vla-object ent)) "")
          ); progn
        ); if
      ); repeat
    ); progn
  ); if
  (*error* nil); exit cleanly
); defun

HTH, M.R.

[marko_ribar]

One mistake I've noticed now... Block names can contain spaces so this and everywhere (getstring) occurs should be :

(setq bn (getstring T "\nSpecify block name for insertion process : "))

Note that "T" - meaning spaces allowed in string specification...

[marko_ribar]

One more mistake :

            (if (> (- (vlax-curve-getDistAtPoint ent end) dist) dist)
              ; Fence-crossing point closer to start than end
              (setq ; then
                inspt (vlax-curve-getStartPoint ent)
                rotpt (polar inspt (angle '(0.0 0.0) (vlax-curve-getFirstDeriv ent (vlax-curve-getStartParam ent))) 1.0)
              ); setq
              (setq ; else [closer to end]
                inspt (vlax-curve-getEndPoint ent)
                rotpt (polar inspt (angle '(0.0 0.0) (vlax-curve-getFirstDeriv ent (vlax-curve-getEndParam ent))) -1.0)
              ); setq
            ); if

Look in red marked function...

[ВeekeeCZ · Accepted solution]

---

@Edwin.Saez.Jamanca wrote:

@ВeekeeCZ,

I worked fine by changing those parameters.
Could you do something about the errors that I show in the images?
In the case of the polyline with continuous line type, it could be excluded to place the blocks?
Perhaps adding some restriction when you select the polylines of a predefined layer, do not consider it at the time of placing the blocks.

- Could one also configure the scale before placing the blocks?

---

Here you have some examples how to exclude/include objects by specific properties

  (setq ss (ssget '((0 . "LWPOLYLINE")
		    (-4 . "<NOT") 	(8 . "Layer1,Layer2") 	(-4 . "NOT>") 
		    (-4 . "<NOT") 	(6 . "Continuous") 	(-4 . "NOT>") 
		    )))

Scale setting:

(or *cap-scale*
    (setq *cap-scale* 5.))
(setq *cap-scale* (cond ((getreal (strcat "\nScale <" (rtos *cap-scale*) ">: ")))
			(*cap-scale*)))

If you have issues with some particular drawings, post the dwg.

[Edwin.Saez]

dear @ВeekeeCZ,

Could you please tell me where I put the scale configuration code?
* I also attach a dwg, so you can see that some cases give me error, placing the block in places where it should not.

thanks for your help

[ВeekeeCZ · Accepted solution]

Ok, the issue should be fixed. Scale added.

(vl-load-com)

(defun c:caps ( / *error* en ss i sb se pb pb1 pb2 pe pe1 pe2 la pt ang par)
  		; global vars: *cap-block* *cap-scale*
  
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
      ); if
    (vla-endundomark doc)
    (princ)
    )
  
  (vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
  
  (if (and (or *cap-block*
               (setq *cap-block* (if (and (setq en (car (entsel "\nSelect a cap block: ")))
                                          (= "INSERT" (cdr (assoc 0 (entget en)))))
                                   (cdr (assoc 2 (entget en))))))
           (or *cap-scale*
               (setq *cap-scale* 5.))
           (setq *cap-scale* (cond ((getreal (strcat "\nSet scale of block <" (rtos *cap-scale*) ">: ")))
                                   (*cap-scale*)))
           (setq ss (ssget '((0 . "LWPOLYLINE"))))
           (not (command "_.ZOOM" "_E"))
           (sssetfirst nil nil)
           )
    (repeat (setq i (sslength ss))
      (setq en (ssname ss (setq i (1- i)))
            pb (vlax-curve-getStartPoint en)
            pe (vlax-curve-getEndPoint en)
            sb (ssget "_C"
                      (setq pb1 (polar (trans pb 0 1) (* pi 0.25) 3))
                      (setq pb2 (polar (trans pb 0 1) (* pi 1.25) 3)))
            se (ssget "_C"
                      (setq pe1 (polar (trans pe 0 1) (* pi 0.25) 3))
                      (setq pe2 (polar (trans pe 0 1) (* pi 1.25) 3)))
            la (cdr (assoc 8 (entget en))))
      ;(command "_.RECTANG" "_none" pb1 "_none" pb2)   										;; Uncomment to see the selection window
      ;(command "_.RECTANG" "_none" pe1 "_none" pe2)   										;; Uncomment to see the selection window
      (if (and (or (and (= 1 (sslength sb))
                        (/= 1 (sslength se))
                        (setq pt pb))
                   (and (/= 1 (sslength sb))
                        (= 1 (sslength se))
                        (setq pt pe))
                   (and (setq pt pb)
                        (setq par (setq par (vlax-curve-getParamAtPoint en (vlax-curve-getClosestPointTo en pt))))
                        (setq ang (angle (trans pt 0 1) (trans (vlax-curve-getPointAtParam en (+ par (if (= (fix par) 0) 0.1 -0.1))) 0 1)))
                        (not (command "_.INSERT" *cap-block* "_s" *cap-scale* "_none" (trans pt 0 1) (angtos ang)
                                      "_.CHPROP" "_L" "" "_La" la ""))
                        (setq pt pe))
                   )
               (setq par (setq par (vlax-curve-getParamAtPoint en (vlax-curve-getClosestPointTo en pt))))
               (setq ang (angle (trans pt 0 1) (trans (vlax-curve-getPointAtParam en (+ par (if (= (fix par) 0) 0.1 -0.1))) 0 1)))
               )
        (command "_.INSERT" *cap-block* "_s" *cap-scale* "_none" (trans pt 0 1) (angtos ang)
                 "_.CHPROP" "_L" "" "_La" la ""))))
  (vla-endundomark doc)
  (princ)
  )