Author Topic: FUNCTION TO PLACE BLOCKS AT ENDPOINTS  (Read 2742 times)

0 Members and 1 Guest are viewing this topic.

Fabricio28

  • Swamp Rat
  • Posts: 631
FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« on: August 09, 2012, 09:29:18 AM »
This lisp put point at endpoints. I'd like to change, put a specific block at endpoints.
Can somebody help me??
 
(princ "tDigite pontos p/ara iniciar ")
(defun contos ()
(setvar"cmdecho" 0)
;(command "osmode" 0)
(command "angbase" 270)
(command "angdir" 1)
(setq flagv "falso")
(setq controle 0)
(setq controle1 0)
(setq contador 0)
(while (= flagv "falso")
 (setq mostre (entsel "\nMostre a Polyline <2d> : "))
(setq linha (entget (car mostre )))
(setq verificador (cdr(assoc 0 linha)))
(if (= verificador "LWPOLYLINE")
(progn
(setq verif (cdr (assoc 70 linha)))
(setq flagv "verdade")
)
(princ "tNão é Polyline !! ")
)
)

(setq controle1 (length linha))
(setq amostra '())
(repeat controle1
(setq x (caar linha))
(if (= x 10)
(progn
(setq item (car linha))
(setq amostra (cons item amostra))
(setq contador (1+ contador))
)
)
(setq linha (cdr linha))
)
(setq amostra1 (reverse amostra))
(if (= verif 1)
(setq amostra (cons (car amostra1) amostra))
(setq contador (1- contador))
)
(setq controle contador)
(repeat controle
(setq PTO1 (cdr(car amostra)))
(setq PTO2 (cdr(car(cdr amostra))))
(AZIMUTAR)
(setq amostra(cdr amostra))
)
(princ)
)
(defun AZIMUTAR ()
(setq padroes (getvar "osmode"))
(setvar"cmdecho" 0)
(command "osmode" 0)
(setq A PTO1)
(setq B PTO2)
;;(setq C " - Az ")
;;(setq D (angtos (angle A B) 1 4))
;;(MUDAR)
;;(setq E (rtos (distance A B) 2 4))
;;(setq DADO (strcat E C PALAV))
;;(PARALELO)
;;(command "text" "j" "mc" ponto_meio 2.5 inicio dado )
;;(command "osmode" padroes)
(setq angulo (angle A B))
(setq ang2 (+ angulo (dtr 90)))
(princ angulo)
(princ ang2)
 (entmake
 (list (cons 0 "point")
 (cons 10 B)
 )
 )
 )
 (defun PARALELO ()
(setq A1 (polar A (+ (/ pi 2)(angle B A )) 2))
(setq B1 (polar B (+ (/ pi 2)(angle B A )) 2))
(setq ptx (/ (+ (car B1) (car A1)) 2))
(setq pty (/ (+ (cadr B1) (cadr A1)) 2))
(setq ponto_meio (list ptx pty))
(if (< (car A1)(car B1))
(setq inicio B1)
(setq inicio A1)
)
)
(defun MUDAR ()
(setq XL 2)
(setq J "d")
(setq COM1 (substr D 1 1))
(while (< XL 5)
(setq LETRAT (substr D XL 1))
(setq RESTOT (substr D (+ 1 XL) ))
(if (= LETRAT J)
(progn (setq J "%%d")
(setq XL 6)
(setq PALAV (strcat COM1 J RESTOT))
)
)
(setq COM1 (strcat COM1 LETRAT ))
(setq XL (1+ XL))
)
)
(defun RTD ()
(/ (* (angle A B) 180) Pi)
)
(defun DTR (AZIMUTE)
(* (/ AZIMUTE 180.0) pi) ;; esta linha também foi alterada
)
 
Best Regards

Lee Mac

  • Seagull
  • Posts: 12255
  • London, England
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #1 on: August 09, 2012, 09:42:11 AM »
Please read this thread regarding formatting code in your posts  :-)

Fabricio28

  • Swamp Rat
  • Posts: 631
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #2 on: August 09, 2012, 09:50:57 AM »
This lisp put point at endpoints. I'd like to change, put a specific block at endpoints.
Can somebody help me??
 
Code: [Select]
(princ "tDigite pontos p/ara iniciar ")
(defun contos ()
(setvar"cmdecho" 0)
;(command "osmode" 0)
(command "angbase" 270)
(command "angdir" 1)
(setq flagv "falso")
(setq controle 0)
(setq controle1 0)
(setq contador 0)
(while (= flagv "falso")
 (setq mostre (entsel "\nMostre a Polyline <2d> : "))
(setq linha (entget (car mostre )))
(setq verificador (cdr(assoc 0 linha)))
(if (= verificador "LWPOLYLINE")
(progn
(setq verif (cdr (assoc 70 linha)))
(setq flagv "verdade")
)
(princ "tNão é Polyline !! ")
)
)

(setq controle1 (length linha))
(setq amostra '())
(repeat controle1
(setq x (caar linha))
(if (= x 10)
(progn
(setq item (car linha))
(setq amostra (cons item amostra))
(setq contador (1+ contador))
)
)
(setq linha (cdr linha))
)
(setq amostra1 (reverse amostra))
(if (= verif 1)
(setq amostra (cons (car amostra1) amostra))
(setq contador (1- contador))
)
(setq controle contador)
(repeat controle
(setq PTO1 (cdr(car amostra)))
(setq PTO2 (cdr(car(cdr amostra))))
(AZIMUTAR)
(setq amostra(cdr amostra))
)
(princ)
)
(defun AZIMUTAR ()
(setq padroes (getvar "osmode"))
(setvar"cmdecho" 0)
(command "osmode" 0)
(setq A PTO1)
(setq B PTO2)
;;(setq C " - Az ")
;;(setq D (angtos (angle A B) 1 4))
;;(MUDAR)
;;(setq E (rtos (distance A B) 2 4))
;;(setq DADO (strcat E C PALAV))
;;(PARALELO)
;;(command "text" "j" "mc" ponto_meio 2.5 inicio dado )
;;(command "osmode" padroes)
(setq angulo (angle A B))
(setq ang2 (+ angulo (dtr 90)))
(princ angulo)
(princ ang2)
 (entmake
 (list (cons 0 "point")
 (cons 10 B)
 )
 )
 )
 (defun PARALELO ()
(setq A1 (polar A (+ (/ pi 2)(angle B A )) 2))
(setq B1 (polar B (+ (/ pi 2)(angle B A )) 2))
(setq ptx (/ (+ (car B1) (car A1)) 2))
(setq pty (/ (+ (cadr B1) (cadr A1)) 2))
(setq ponto_meio (list ptx pty))
(if (< (car A1)(car B1))
(setq inicio B1)
(setq inicio A1)
)
)
(defun MUDAR ()
(setq XL 2)
(setq J "d")
(setq COM1 (substr D 1 1))
(while (< XL 5)
(setq LETRAT (substr D XL 1))
(setq RESTOT (substr D (+ 1 XL) ))
(if (= LETRAT J)
(progn (setq J "%%d")
(setq XL 6)
(setq PALAV (strcat COM1 J RESTOT))
)
)
(setq COM1 (strcat COM1 LETRAT ))
(setq XL (1+ XL))
)
)
(defun RTD ()
(/ (* (angle A B) 180) Pi)
)
(defun DTR (AZIMUTE)
(* (/ AZIMUTE 180.0) pi) ;; esta linha também foi alterada
)

Best Regards
Thanks Lee

Fabricio28

  • Swamp Rat
  • Posts: 631
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #3 on: August 10, 2012, 12:56:17 PM »
Hey all,
I have a code that put block at the measure intervals. I'd like to change this code and put block at  endppoints.
Help me guys, please.

Code: [Select]
;; Function to place blocks at measured intervals
(defun c:MeasureCSV (/ bname path dist ss n en ed fn f)
  ;; Ask user to select path, distance & block name
  (if (and (setq path (entsel "Select object to measure: ")) ;Check if user's picked an object
           (setq dist (getdist "Specify length of segment: ")) ;Check if user's specified distance
           (setq bname (getstring t "Enter name of block to insert: ")) ;Check if user's specified block name
           (tblsearch "BLOCK" bname) ;Check if block exists
      ) ;_ end of and
    (progn
      ;; Do the Measure command
      (command "_.MEASURE" path "_Block" bname "_Yes" dist)

      ;; Get a selection set of the blocks created
          (if (setq ss (ssget "P")) ;Select previous
            (progn
              (setq n 0) ;initialize counter
              (while (< n (sslength ss)) ;While counter is less than selection set's length
                (setq en (ssname ss n) ;Get the nth item from the selection set
                      ed (entget en) ;Get its DXF data list
                ) ;_ end of setq
                (write-line
                  (strcat (rtos (cadr (assoc 10 ed))) ;X value
                          ","
                          (rtos (caddr (assoc 10 ed))) ;Y value
                          ","
                          (rtos (cadddr (assoc 10 ed))) ;Z value
                  ) ;_ end of strcat
                  f
                ) ;_ end of write-line
                (setq n (1+ n)) ;Increment counter
              ) ;_ end of while
            ) ;_ end of progn
          ) ;_ end of if

          (close f) ;Close the file
        ) ;_ end of progn
        (princ "Stopped.")
      ) ;_ end of if
    ) ;_ end of progn
    (princ "*Invalid*") ;Else stop & show error
  ) ;_ end of if
  (princ) ;Don't show anything else on command line
) ;_ end of defun

Thanks in advance

CAB

  • Global Moderator
  • Seagull
  • Posts: 10362
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #4 on: August 10, 2012, 02:31:43 PM »
Maybe this old lisp will do.
Code: [Select]
;;  BlockAddEOL.lsp 
;;  Block Add to End Of Line
;;  CAB 11.13.08  Version 1.1

(defun c:block2end (/ ss s1 bname ent ename lset doc space s e i )
  (vl-load-com)
  ;;  sub to insert the block
  (defun InsertBlock (bn pt ang lay aspace)
      (setq blk (vla-insertblock
  aspace
  (vlax-3d-point pt) ; insert point
  bn ; block name
  1.  ; scale x
  1.
  1.
  ang  ; radians
)
      )
     (vla-put-layer blk lay)
    blk
  )
  ;;; Returns object to active space (ModelSpace or PaperSpace )
  ;;  CAB 05/31/07
  (defun activespace (doc)
    (if (or (= acmodelspace (vla-get-activespace doc))
            (= :vlax-true (vla-get-mspace doc)))
        (vla-get-modelspace doc)
        (vla-get-paperspace doc)
    )
  )

  (defun getss@ (pt typs lay / ss sz vs pb swp ar wsd ppdu box)
    ;;==============================================
    ;;  CAB version
    ;; do a ssget crossing the size of the pickbox at the pick point
    (setq SZ   (getvar "SCREENSIZE") ; screen size in pixels
          VS   (getvar "VIEWSIZE") ; screen height in drawing units
          PB   (getvar "pickbox") ; get current pickbox size
          SWP  (car SZ) ; width of screen in pixels
          SHP  (cadr SZ) ; height of screen in pixels
          AR   (/ SWP SHP) ; aspect ratio width/height
          WSD  (* VS AR) ; width of screen dwg units = ratio times height
          PPDU (/ WSD SWP) ; pixels per drawing unit
          BOX  (/ (* VS (* 2 PB)) SHP) ; drawing units per pixel
    )
    (setq ss (ssget "_C"
                    (polar pt 0.785 box)
                    (polar pt 3.93 box)
                    (list (cons 0 typs) (cons 8 lay))
             )
    )
  )
 
  ;;=============================
  ;;  Start Here
  (setq LineLay "*") ; filter for line layer
  (setq blklay "0")  ; filter for block layer
  (prompt "\nSelect block to use or ENTER key to name block.")
  (if
    (and
      (or
       (and (setq ss (ssget "_+.:E:S" '((0 . "INSERT"))))
            (setq ent (ssname ss 0))
            (setq bname (cdr(assoc 2 (entget ent)))))
       (and (setq bname (getstring t "\nName of block to copy: "))
            (or (tblsearch "Block" bname)
                (prompt (strcat "Cannot find Block " bname ", Ending."))))
      )
      (or (prompt "\nSelect lines to test.")
          (setq lset (ssget (list '(0 . "line")(cons 8 LineLay))))   ;filter line in selection set
      )
    )
      (progn
        (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
              space (activespace doc))
        (vla-EndUndoMark doc)
        (vla-StartUndoMark doc)
        (vla-zoomextents (vlax-get-acad-object))
        (setq i -1)
        (while (setq ename (ssname lset (setq i (1+ i))))
          (setq elst (entget ename)
                s (cdr(assoc 10 elst))
                e (cdr(assoc 11 elst)))
          (if (= (sslength (setq s1 (getss@ s "LINE" Linelay))) 1)
            (InsertBlock bname s (angle e s) blklay space)
          )
          (if (= (sslength (setq s1 (getss@ e "LINE" Linelay))) 1)
            (InsertBlock bname e (angle s e) blklay space)
          )
        )
        (vla-zoomprevious (vlax-get-acad-object))
        (vla-EndUndoMark doc)
      )
  ) ; endif

 (princ "\nThe blocks have been copied")
 (princ)               
)
(princ)


I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

Fabricio28

  • Swamp Rat
  • Posts: 631
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #5 on: August 10, 2012, 03:29:58 PM »
Thanks for replay, CAB
I need a lisp that put blocks at endpoints of a polilyne.


file attached.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10362
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #6 on: August 10, 2012, 03:48:18 PM »
You are saying that you can't modify that lisp to work with polylines?
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

Fabricio28

  • Swamp Rat
  • Posts: 631
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #7 on: August 10, 2012, 04:05:39 PM »
I've already modify that lisp to work with polylines, CAB...
But I don't know how to put the block in each endpoints of a polyline.

Code: [Select]

;; Function to place blocks at end intervals
(vl-load-com) ; initialize vla functions
(defun c:EndsCSV (/ bname path dist ss n en ed fn f)
  ;; Ask user to select path, distance & block name
  (if (and (setq path (car (entsel "Select object to measure end points: "))) ;Check if user's picked an object
           (setq dist (- (vlax-curve-getdistatpoint (vlax-ename->vla-object path) (vlax-curve-getendpoint (vlax-ename->vla-object path))) (vlax-curve-getdistatpoint (vlax-ename->vla-object path) (vlax-curve-getstartpoint (vlax-ename->vla-object path))) )) ;Check if specified distance
           (setq bname (getstring t "Enter name of block to insert: ")) ;Check if user's specified block name
           (tblsearch "BLOCK" bname) ;Check if block exists
      ) ;_ end of and
    (progn
      ;; Do the Measure command
      (command "_.MEASURE" path "_Block" bname "_Yes" dist)

      ;; Get a selection set of the blocks created
          (if (setq ss (ssget "P")) ;Select previous
            (progn
              (setq n 0) ;initialize counter
              (while (< n (sslength ss)) ;While counter is less than selection set's length
                (setq en (ssname ss n) ;Get the nth item from the selection set
                      ed (entget en) ;Get its DXF data list
                ) ;_ end of setq
                (write-line
                  (strcat (rtos (cadr (assoc 10 ed))) ;X value
                          ","
                          (rtos (caddr (assoc 10 ed))) ;Y value
                          ","
                          (rtos (cadddr (assoc 10 ed))) ;Z value
                  ) ;_ end of strcat
                  f
                ) ;_ end of write-line
                (setq n (1+ n)) ;Increment counter
              ) ;_ end of while
            ) ;_ end of progn
          ) ;_ end of if

          (close f) ;Close the file
        ) ;_ end of progn
        (princ "Stopped.")
      ) ;_ end of if
    ) ;_ end of progn
    (princ "*Invalid*") ;Else stop & show error
  ) ;_ end of if
  (princ) ;Don't show anything else on command line
) ;_ end of defun

ribarm

  • Water Moccasin
  • Posts: 2123
  • Marko Ribar, architect
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #8 on: August 10, 2012, 06:01:16 PM »
I've tested CAB's version and did slightly modifications to suit your needs and it works fine...

Code: [Select]
;;  BlockAddEOC.lsp 
;;  Block Add to End Of Curve
;;  CAB 11.13.08  Version 1.1
;;  M.R. modified 10.08.12

(defun c:block2end (/ ss s1 bname ent ename lset doc space s sa e ea i )
  (vl-load-com)
  ;;  sub to insert the block
  (defun InsertBlock (bn pt ang lay aspace)
      (setq blk (vla-insertblock
  aspace
  (vlax-3d-point pt) ; insert point
  bn ; block name
  1.  ; scale x
  1.
  1.
  ang  ; radians
)
      )
     (vla-put-layer blk lay)
    blk
  )
  ;;; Returns object to active space (ModelSpace or PaperSpace )
  ;;  CAB 05/31/07
  (defun activespace (doc)
    (if (or (= acmodelspace (vla-get-activespace doc))
            (= :vlax-true (vla-get-mspace doc)))
        (vla-get-modelspace doc)
        (vla-get-paperspace doc)
    )
  )

  (defun getss@ (pt typs lay / ss sz vs pb swp ar wsd ppdu box)
    ;;==============================================
    ;;  CAB version
    ;; do a ssget crossing the size of the pickbox at the pick point
    (setq SZ   (getvar "SCREENSIZE") ; screen size in pixels
          VS   (getvar "VIEWSIZE") ; screen height in drawing units
          PB   (getvar "pickbox") ; get current pickbox size
          SWP  (car SZ) ; width of screen in pixels
          SHP  (cadr SZ) ; height of screen in pixels
          AR   (/ SWP SHP) ; aspect ratio width/height
          WSD  (* VS AR) ; width of screen dwg units = ratio times height
          PPDU (/ WSD SWP) ; pixels per drawing unit
          BOX  (/ (* VS (* 2 PB)) SHP) ; drawing units per pixel
    )
    (setq ss (ssget "_C"
                    (polar pt 0.785 box)
                    (polar pt 3.93 box)
                    (list (cons 0 typs) (cons 8 lay))
             )
    )
  )
 
  ;;=============================
  ;;  Start Here
  (setq CurveLay "*") ; filter for curve layer
  (setq blklay "0")  ; filter for block layer
  (prompt "\nSelect block to use or ENTER key to name block.")
  (if
    (and
      (or
       (and (setq ss (ssget "_+.:E:S" '((0 . "INSERT"))))
            (setq ent (ssname ss 0))
            (setq bname (cdr(assoc 2 (entget ent)))))
       (and (setq bname (getstring t "\nName of block to copy: "))
            (or (tblsearch "Block" bname)
                (prompt (strcat "Cannot find Block " bname ", Ending."))))
      )
      (or (prompt "\nSelect curves to test.")
          (setq lset (ssget (list '(0 . "*line,ellipse,arc")(cons 8 CurveLay))))   ;filter curve in selection set
      )
    )
      (progn
        (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
              space (activespace doc))
        (vla-EndUndoMark doc)
        (vla-StartUndoMark doc)
        (vla-zoomextents (vlax-get-acad-object))
        (setq i -1)
        (while (setq ename (ssname lset (setq i (1+ i))))
          (setq sa (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv (vlax-ename->vla-object ename) (vlax-curve-getstartparam (vlax-ename->vla-object ename))))
                ea (angle (vlax-curve-getfirstderiv (vlax-ename->vla-object ename) (vlax-curve-getendparam (vlax-ename->vla-object ename))) '(0.0 0.0 0.0))
                s (vlax-curve-getstartpoint (vlax-ename->vla-object ename))
                e (vlax-curve-getendpoint (vlax-ename->vla-object ename)))
          (if (= (sslength (getss@ s "*LINE,ELLIPSE,ARC" Curvelay)) 1)
            (InsertBlock bname s sa blklay space)
          )
          (if (= (sslength (getss@ e "*LINE,ELLIPSE,ARC" Curvelay)) 1)
            (InsertBlock bname e ea blklay space)
          )
        )
        (vla-zoomprevious (vlax-get-acad-object))
        (vla-EndUndoMark doc)
      )
  ) ; endif

 (princ "\nThe blocks have been copied")
 (princ)               
)
(princ "\nType block2end to invoke")
(princ)

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2123
  • Marko Ribar, architect
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #9 on: August 13, 2012, 02:10:05 PM »
Sorry FABRICIO28, I didn't see dwg you posted... I think that for this purpose you want, maybe the best solution is Lee Mac's PointManager...

http://www.lee-mac.com/ptmanager.html

Regards,
M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Matt__W

  • Seagull
  • Posts: 12951
  • I like my water diluted.
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #10 on: August 13, 2012, 03:13:54 PM »
You can also give this one a shot.  You'll need to add some error trapping/clean up code which I removed but it works on lines/plines/arcs but it's manual, meaning you have to select each end separately to place a block.  We use this for adding "break" symbols to wires and tick marks to contours.

Code: [Select]
(defun DXF (code lst)
   (cdr (assoc code lst))
)

(defun pline_block (strBlockPath strBlockName strUseLTScale /
                    objEnt pt1 pt2 ent2 layName ang lts objType)

   (while (setq objEnt (entsel "\n Select a point on a line/pline/arc... "))
      (progn
         (setq objType (cdr (assoc 0 (entget (car objEnt)))))
         (princ objType)
         (setq pt1 (osnap (cadr objEnt) "_nea"))
         (setq pt2 (osnap (cadr objEnt) "_endp"))
         (setq ent2 (entget (setq entList (car objEnt))))
         (setq layName (DXF 8 ent2))
         (if (= strUseLTScale "Y")
            (setq lts (getvar "ltscale"))
            (setq lts 1.0)
         )
         (setvar "clayer" layName)
         (setq ang (angle pt1 pt2))
         (command "-insert" (strcat strBlockPath strBlockName) pt2 lts "" (rtd ang))
      )
   )
   (princ)
)

Use this to pass a block path and name to the program and a "Y" or "" to either use the current LTScale or 1.0 to set the block's scale.
Code: [Select]
(pline_block "E:\\temp\\" "test" "Y")
Autodesk Expert Elite
Autodesk Revit Architecture, Structure, MEP Mechanical and MEP Electrical Certified Professional
Building Performance Analysis Certified (BPAC v3.0)
Autodesk Navisworks 2014 Essentials

Fabricio28

  • Swamp Rat
  • Posts: 631
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #11 on: August 15, 2012, 07:41:52 AM »
Thanks all of you, guys!
This Lee Mac program is exactly I was looking for. It works perfect!

Thanks Matt W for your suggestion!

Best Regards.
 :mrgreen:

jpcadconsulting

  • Newt
  • Posts: 52
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #12 on: February 05, 2019, 04:53:59 PM »
Hiya gang,

I've modified this code to (Almost) do what I need.  The only thing it's not currently doing properly is adjusting the rotation angle of each block insertion to the end of each line.  It juts inserts then all at the same rotation (presumably of the first object in the list).

Any help is appreciated!!!

Code below (my additions in RED)

Code: [Select]
(defun c:test3 (/ANG CL SCL DBX ss s1 bname ent ename lset doc space s e i )
  (vl-load-com)

***** Get current layer info and make new layer for inserted blocks *****
[color=red](setq CL (getvar "CLAYER"))
(command "_.-Layer" "m" "L-ANNO-SYMB" "c" "3" "L-ANNO-SYMB" "")[/color]



[color=red]***** Determine INUNITS value and set scale for inserted blocks *****
(cond ((= (getvar "INSUNITS") 1) (setq SCL 1))
      ((= (getvar "INSUNITS") 2) (setq SCL 0.08333))
      ((= (getvar "INSUNITS") 4) (setq SCL 25.4))
      ((= (getvar "INSUNITS") 5) (setq SCL 2.54))
      ((= (getvar "INSUNITS") 6) (setq SCL 0.0254))
      (t (alert "Current DWG set to non-standard units.  Check UNITS settings"))
)



***** Iport block form seed drawing *****
(defun open_dbx (dwg / dbx)
   (if (< (atoi (substr (getvar "ACADVER") 1 2)) 16)
      (setq dbx (vlax-create-object "ObjectDBX.AxDbDocument"))
      (setq dbx (vlax-create-object
      (strcat "ObjectDBX.AxDbDocument."
         (substr (getvar "ACADVER") 1 2)
         )
      )
   )
)
(vla-open dbx dwg)
dbx
)
(setq Dbx (open_dbx "X:/AutoCAD 2018/Drawings/Callouts.dwg"))
(vla-CopyObjects
Dbx
(vlax-safearray-fill
(vlax-make-safearray vlax-vbObject '(0 . 0))
(list (vla-item (vla-get-blocks dbx) "MNLA Transition Tick r20"))
)
(vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
)
)
(vlax-release-object dbx)
[/color]



  ;;  sub to insert the block
  (defun InsertBlock (bn pt ang lay aspace)
      (setq blk (vla-insertblock
  aspace
  (vlax-3d-point pt) ; insert point
  bn ; block name
  1.  ; scale x
  1.
  1.
  ang  ; radians
)
      )
     (vla-put-layer blk lay)
    blk
  )
  ;;; Returns object to active space (ModelSpace or PaperSpace )
  ;;  CAB 05/31/07
  (defun activespace (doc)
    (if (or (= acmodelspace (vla-get-activespace doc))
            (= :vlax-true (vla-get-mspace doc)))
        (vla-get-modelspace doc)
        (vla-get-paperspace doc)
    )
  )

  (defun getss@ (pt typs lay / ss sz vs pb swp ar wsd ppdu box)
    ;;==============================================
    ;;  CAB version
    ;; do a ssget crossing the size of the pickbox at the pick point
    (setq SZ   (getvar "SCREENSIZE") ; screen size in pixels
          VS   (getvar "VIEWSIZE") ; screen height in drawing units
          PB   (getvar "pickbox") ; get current pickbox size
          SWP  (car SZ) ; width of screen in pixels
          SHP  (cadr SZ) ; height of screen in pixels
          AR   (/ SWP SHP) ; aspect ratio width/height
          WSD  (* VS AR) ; width of screen dwg units = ratio times height
          PPDU (/ WSD SWP) ; pixels per drawing unit
          BOX  (/ (* VS (* 2 PB)) SHP) ; drawing units per pixel
    )
    (setq ss (ssget "_C"
                    (polar pt 0.785 box)
                    (polar pt 3.93 box)
                    (list (cons 0 typs) (cons 8 lay))
             )
    )
  )
 
  ;;=============================
  ;;  Start Here
  (setq LineLay "*") ; filter for line layer
 [color=red] (setq blklay "L-ANNO-SYMB")  ; filter for block layer[/color]
  (if
    (and
[color=red]      (setq bname "MNLA Transition Tick r20")[/color]
      (or (prompt "\nSelect lines to test.")
          (setq lset (ssget (list '(0 . "line")(cons 8 LineLay))))   ;filter line in selection set
      )
    )
      (progn
        (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
              space (activespace doc))
        (vla-EndUndoMark doc)
        (vla-StartUndoMark doc)
        (vla-zoomextents (vlax-get-acad-object))
        (setq i -1)
        (while (setq ename (ssname lset (setq i (1+ i))))
          (setq elst (entget ename)
                s (cdr(assoc 10 elst))
                e (cdr(assoc 11 elst)))
          (if (= (sslength (setq s1 (getss@ s "LINE" Linelay))) 1)
[color=red]            (command "-insert" "MNLA Transition Tick r20" s SCL SCL (angle e s))[/color]
          )
          (if (= (sslength (setq s1 (getss@ e "LINE" Linelay))) 1)
[color=red]            (command "-insert" "MNLA Transition Tick r20" e SCL SCL (angle e s))[/color]
          )
        )
        (vla-zoomprevious (vlax-get-acad-object))
        (vla-EndUndoMark doc)
      )
  ) ; endif

 (princ "\nThe blocks have been copied")
 (princ)               
)
(princ)

Technology will save us all! *eyeroll*

ronjonp

  • Needs a day job
  • Posts: 7025
Re: FUNCTION TO PLACE BLOCKS AT ENDPOINTS
« Reply #13 on: February 05, 2019, 05:15:56 PM »
If all you are processing is lines then getting the angle is pretty straight forward:
Code - Auto/Visual Lisp: [Select]
  1. (setq a (angle (cdr (assoc 10 (entget enameline))) (cdr (assoc 11 (entget enameline)))))
  2. ;; vanilla ( strange results if block has attributes )
  3. (entmod (append (entget enameblock) (list (cons 50 a))))
  4. ;; vla
  5. (vla-put-rotation vlablock (vla-get-angle vlaline))

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC