Jump to content

Insert block in midpoint of lines filtered by length

Miller87

By Miller87
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Miller87 Apprentice

Miller87

Posted
Posted

Goodmorning, I would need a lisp that automatically insert a block in the midpoint of every specific line of predetermined lenght.

 

I've created in my drawing several block called:

-"50m" -> insert in midpoint of lines with 500 mm

-"100m" -> insert in midpoint of lines with 1000 mm.

ecc..

I write this coarse code :?

 

(defun C:blockparlines (/)

 (setq s (ssget "x" '((0 . "LINE" ))))




;FILTER SELECTION FOR LINES WITH LENGTH 500 mm
(setq ss1 (ssadd))
(setq lung 500)
(setq ss2 s)
(if ss2 (progn
(setq i 0  ssl (sslength ss2))
(repeat ssl
 (setq ename (ssname ss2 i))
 (setq ll (distance (cdr (assoc 10 (entget ename))) (cdr (assoc 11 (entget ename)))))
 (if (= lung ll)(ssadd ename ss1))
 (setq i (1+ i))
 )
(princ (strcat (itoa (sslength ss1)) " generated block's of 500 mm."))
;(sssetfirst nil ss1)
))
(princ)


;INSERT BLOCK IN MIDPOINT of 500 mm

(setq name "50M")
(repeat (setq i (sslength ss1))
      (setq e (entget (ssname ss1 (setq i (1- i)))))
      (entmakex
        (list '(0 . "INSERT")
              (cons 10
                    (mapcar (function (lambda (q p) (/ (+ q p) 2.)))
                            (setq p1 (cdr (assoc 10 e)))
                            (setq p2 (cdr (assoc 11 e)))
                    )
              )
              (cons 2 name)
              (cons 50 (angle p1 p2))
              '(41 . 1.0)
              '(42 . 1.0)
              '(43 . 1.0)
        )
      )
)
(princ)


;RESET SS1 
 (setq ss1 nil)
 (setq ss1 (ssadd))

;FILTER SELECTION FOR LINES WITH LENGTH 1000 mm

(setq lung 1000)
(setq ss2 s)
(if ss2 (progn
(setq i 0  ssl (sslength ss2))
(repeat ssl
 (setq ename (ssname ss2 i))
 (setq ll (distance (cdr (assoc 10 (entget ename))) (cdr (assoc 11 (entget ename)))))
 (if (= lung ll)(ssadd ename ss1))
 (setq i (1+ i))
 )
(princ (strcat (itoa (sslength ss1)) " generated block's of 1000 mm."))
(sssetfirst nil ss1)
))
(princ)

;INSERT BLOCK IN MIDPOINT of 1000 mm

(setq name "100M")
(repeat (setq i (sslength ss1))
      (setq e (entget (ssname ss1 (setq i (1- i)))))
      (entmakex
        (list '(0 . "INSERT")
              (cons 10
                    (mapcar (function (lambda (q p) (/ (+ q p) 2.)))
                            (setq p1 (cdr (assoc 10 e)))
                            (setq p2 (cdr (assoc 11 e)))
                    )
              )
              (cons 2 name)
              (cons 50 (angle p1 p2))
              '(41 . 1.0)
              '(42 . 1.0)
              '(43 . 1.0)
        )
      )
)
(princ)

;RESET SS1 
 (setq ss1 nil)
 (setq ss1 (ssadd))


 )

 

Here is the bugs:

-it doesn't consider the lines along XZ YZ plane? I don't understand why.

-this is very long code i've got 10 or more blocks to insert by length. An easy way to get the routine optimized?

 

Thanks

Miller

Link to comment
Share on other sites
Miller87 Apprentice

Miller87

Posted
  • Author
Posted

List of the blocks to associated at the lines:

"50M" -> in midpoints of lines of length 500 mm

"100M" -> in midpoints of lines of length 1000 mm

"150M" -> in midpoints of lines of length 1500 mm

"200M" -> in midpoints of lines of length 2000 mm

"250M" -> in midpoints of lines of length 2500 mm

"300M" -> in midpoints of lines of length 3000 mm

Link to comment
Share on other sites
Tharwat Grand Master

Tharwat

Posted
Posted

Try this and let know .

 

[ NOT TESTED ]

 

(defun c:Test  (/ l ss)
 ;;;	Tharwat 27.4.2015	;;;
 (setq l '(("50M" 500)
           ("100M" 1000)
           ("150M" 1500)
           ("200M" 2000)
           ("250M" 2500)
           ("300M" 3000))
       )
 (if (setq ss (ssget '((0 . "LINE"))))
   ((lambda (i / sn a b f)
      (while (setq sn (ssname ss (setq i (1+ i))))
        (if
          (and (vl-some
                 '(lambda (x)
                    (equal
                      (distance
                        (setq a (cdr (assoc 10 (entget sn))))
                        (setq b (cdr (assoc 11 (entget sn)))))
                      (cadr (setq f x))
                      1e-)
                 l)
               (tblsearch "BLOCK" (car f))
               )
           (entmake (list '(0 . "INSERT")(cons 10 (mapcar (function (lambda (q p) (/ (+ q p) 2.)))
                                                          a
                                                          b
                                                          ))
                          (cons 2 (car f))
                          (cons 50 (angle a b))
                          '(41 . 1.0)
                          '(42 . 1.0)
                          '(43 . 1.0)
                          )
                    ))))  -1)
   )
 (princ)
 )

Link to comment
Share on other sites
Miller87 Apprentice

Miller87

Posted
  • Author
Posted

Thanks It works! :D

But I need to modify a little bit.

Filter selection for vertical lines Z and reject all the other lines from selection.

Thanks again

Link to comment
Share on other sites
Tharwat Grand Master

Tharwat

Posted
Posted
Thanks It works! :D

 

Thanks again

 

Excellent , you are welcome :)

 

But I need to modify a little bit.

Filter selection for vertical lines Z and reject all the other lines from selection.

 

I am sorry , I did not get your point . explain it a little bit further .

Link to comment
Share on other sites
Miller87 Apprentice

Miller87

Posted
  • Author
Posted
Excellent , you are welcome :)

 

 

 

I am sorry , I did not get your point . explain it a little bit further .

 

mlu73fc.png?1

 

I would like to select ONLY the vertical lines (as you can see in picture in RED) that belong plane YZ XZ before filtering by distance.

Is that possible?

Thanks

Link to comment
Share on other sites
Tharwat Grand Master

Tharwat

Posted
Posted

We can iterate through the selection for a specific criteria of the lines , and if it is matched let the codes move to the other criteria to check it out .

 

Can you upload that sample drawing ?

Link to comment
Share on other sites
Miller87 Apprentice

Miller87

Posted
  • Author
Posted
We can iterate through the selection for a specific criteria of the lines , and if it is matched let the codes move to the other criteria to check it out .

 

Can you upload that sample drawing ?

 

Here it is.

You have vertical lines in red ready with length 1000 and 1500.

sample.dwg

Link to comment
Share on other sites
Tharwat Grand Master

Tharwat

Posted
Posted

I think that you can't because also the white lines are have a Z coordinate equal to either start/end point of red lines .

 

You may work around this issue by filtering the lines by Layer / Color ... etc.

Link to comment
Share on other sites
Miller87 Apprentice

Miller87

Posted
  • Author
Posted
I think that you can't because also the white lines are have a Z coordinate equal to either start/end point of red lines .

 

You may work around this issue by filtering the lines by Layer / Color ... etc.

 

I found this your old code ;) and with a little modify It may works.

There are still some bug and it's not optimized.

 

(defun c:VHlines ( / _Ang *error* kw e i sn ss )
 ;;; Tharwat 13. Dec. 2012  ;;;
 ;;; modified by miller87 27/04/2015 
 (defun _Ang (e) (angle (cddr (assoc 10 e)) (cddr (assoc 11 e))))
 (defun *error* (msg) (princ "\n Error...*Cancelled*"))
 (if (and (progn 
                 (setq kw "Vertical"
                 )
          )
          (setq s  (ssadd)
                ss (ssget "_x" (list '(0 . "LINE") (cons 410 (getvar 'ctab))))
          )
     )
   (progn
     (repeat (setq i (sslength ss))
       (setq sn (ssname ss (setq i (1- i)))
             e  (entget sn)
       )
       (cond ((eq kw "Vertical")
              (if (or (equal (_Ang e) (* pi 0.5)) (equal (_Ang e) (* pi 1.5)))
                (ssadd sn s)
              )
             )
             ((eq kw "Horizontal")
              (if (or (equal (_Ang e) pi) (equal (_Ang e) 0.))
                (ssadd sn s)
              )
             )
             (t
              (if (or (equal (_Ang e) (* pi 0.5)) (equal (_Ang e) (* pi 1.5)) (equal (_Ang e) pi) (equal (_Ang e) 0.))
                (ssadd sn s)
              )
             )
       )
     )
     (sssetfirst nil s)
   )
 )
 (princ)
)

Link to comment
Share on other sites
David Bethel Grand Master

David Bethel

Posted
Posted

Maybe :

 

[b][color=BLACK]([/color][/b]defun c:mvert [b][color=FUCHSIA]([/color][/b]/ ss i en ed p1 p2 z1 z2 ll ip bn[b][color=FUCHSIA])[/color][/b]
[b][color=FUCHSIA]([/color][/b]and [b][color=NAVY]([/color][/b]setq ss [b][color=MAROON]([/color][/b]ssget [color=#2f4f4f]"X"[/color] '[b][color=GREEN]([/color][/b][b][color=BLUE]([/color][/b]0 . [color=#2f4f4f]"LINE"[/color][b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
     [b][color=NAVY]([/color][/b]setq i 0[b][color=NAVY])[/color][/b]
     [b][color=NAVY]([/color][/b]while [b][color=MAROON]([/color][/b]setq en [b][color=GREEN]([/color][/b]ssname ss i[b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b]
            [b][color=MAROON]([/color][/b]setq ed [b][color=GREEN]([/color][/b]entget en[b][color=GREEN])[/color][/b]
                  p1 [b][color=GREEN]([/color][/b]cdr [b][color=BLUE]([/color][/b]assoc 10 ed[b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b]
                  p2 [b][color=GREEN]([/color][/b]cdr [b][color=BLUE]([/color][/b]assoc 11 ed[b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b]
            [b][color=MAROON]([/color][/b]and [b][color=GREEN]([/color][/b]equal [b][color=BLUE]([/color][/b]car  p1[b][color=BLUE])[/color][/b] [b][color=BLUE]([/color][/b]car  p2[b][color=BLUE])[/color][/b] 1e-8[b][color=GREEN])[/color][/b]
                 [b][color=GREEN]([/color][/b]equal [b][color=BLUE]([/color][/b]cadr p1[b][color=BLUE])[/color][/b] [b][color=BLUE]([/color][/b]cadr p2[b][color=BLUE])[/color][/b] 1e-8[b][color=GREEN])[/color][/b]
                 [b][color=GREEN]([/color][/b]setq z1 [b][color=BLUE]([/color][/b]caddr p1[b][color=BLUE])[/color][/b]
                       z2 [b][color=BLUE]([/color][/b]caddr p2[b][color=BLUE])[/color][/b]
                       ll [b][color=BLUE]([/color][/b]abs [b][color=RED]([/color][/b]- z1 z2[b][color=RED])[/color][/b][b][color=BLUE])[/color][/b]
                       ip [b][color=BLUE]([/color][/b]list [b][color=RED]([/color][/b]car p1[b][color=RED])[/color][/b] [b][color=RED]([/color][/b]cadr p2[b][color=RED])[/color][/b] [b][color=RED]([/color][/b]+ [b][color=PURPLE]([/color][/b]min z1 z2[b][color=PURPLE])[/color][/b] [b][color=PURPLE]([/color][/b]* ll 0.5[b][color=PURPLE])[/color][/b][b][color=RED])[/color][/b][b][color=BLUE])[/color][/b]
                       bn [b][color=BLUE]([/color][/b]strcat [color=#2f4f4f]"M"[/color] [b][color=RED]([/color][/b]rtos ll 2 0[b][color=RED])[/color][/b][b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b]
                 [b][color=GREEN]([/color][/b]tblsearch [color=#2f4f4f]"BLOCK"[/color] bn[b][color=GREEN])[/color][/b]
                 [b][color=GREEN]([/color][/b]entmake [b][color=BLUE]([/color][/b]list [b][color=RED]([/color][/b]cons 0 [color=#2f4f4f]"INSERT"[/color][b][color=RED])[/color][/b][b][color=RED]([/color][/b]cons 2 bn[b][color=RED])[/color][/b][b][color=RED]([/color][/b]cons 10 ip[b][color=RED])[/color][/b][b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b]
            [b][color=MAROON]([/color][/b]setq i [b][color=GREEN]([/color][/b]1+ i[b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]prin1[b][color=FUCHSIA])[/color][/b][b][color=BLACK])[/color][/b]

 

 

The INSERT angle is moot because all LINE point values are WCS.

 

-David

Link to comment
Share on other sites
Miller87 Apprentice

Miller87

Posted
  • Author
Posted

Works!

I modified with the correct names of my blocks:

50M, 100M, 150M, 200M, 250M, 300M

Here the final results:

(defun c:mvert (/ )
(and (setq ss (ssget "X" '((0 . "LINE"))))
     (setq i 0)
     (while (setq en (ssname ss i))
            (setq ed (entget en)
                  p1 (cdr (assoc 10 ed))
                  p2 (cdr (assoc 11 ed)))
            (and (equal (car  p1) (car  p2) 1e-
                 (equal (cadr p1) (cadr p2) 1e-
                 (setq z1 (caddr p1)
                       z2 (caddr p2)
                       ll (/ (abs (- z1 z2)) 10.0)
		lll (* ll 10.0)
                       ip (list (car p1) (cadr p2) (+ (min z1 z2) (* lll 0.5)))
                       bn (strcat  (rtos ll 2 0) "M"))
                 (tblsearch "BLOCK" bn)
                 (entmake (list (cons 0 "INSERT")(cons 2 bn)(cons 10 ip))))
            (setq i (1+ i))))
 (prin1)

 )

 

I could change the name of the blocks but manipulating lisp is more pleasant!!

Thanks David

Link to comment
Share on other sites
David Bethel Grand Master

David Bethel

Posted
Posted

:shock: LOL

 

I did assume that the BLOCK table definitions exist.

 

You could always add BLOCK creations or an INSERT call

 

-Davis

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...