Jump to content

Extend or Trim to orthographic projection of picked point

Simon1976

By Simon1976
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Simon1976 Explorer

Simon1976

Posted
Posted

Please does anyone have an extend/trim to a point lisp?

This surely has been done before but I cannot find it, despite a thorough Google search.

This is my first post & I hope I've added the jpg correctly

Function:

Select a point (var pickpt)

Extend or trim selected lines to an orthographic projection of pickpt

End

In the picture the yellow dashed lines are the orthographic projection of pickpt, the magenta are the lines to be extended/trimmed.

I'd like the actual extending trimming to be done through a repeat loop with the new endpoints created through a polar function, a list created then a subst func

(subst lst (assoc 10 linedxf)

or

(subst lst (assoc 11 linedxf)

Depending on whether assoc 10 or assoc 11 is closer to the pickpoint

My code so far:

(defun c:triangle (/ adj1 ang dist1 hyp1 hyp2 list1 ncos npt p1 p2 P3 pickpt)
 (Setq pickpt (getpoint"\nSelect Pickpoint"))
 (Setq p1 (getpoint"\nSelect Point 1"))
 (Setq p2 (getpoint"\nSelect Point 2"))
 (setq ang (angle p1 p2))
 (setq list1 (list (car pickpt) (cadr p2) 0.0))
 (setq hyp1 (distance p1 p2))
 (setq dist1 (distance p2 list1))
(setq adj1 (* hyp1 (cos ang)))
 (if (< adj1 0.0)
   (setq adj1 (* adj1 -1))
 )
 
(setq ncos (cos ang))
(setq hyp2 (/ dist1 ncos))
 (if (< hyp2 0.0)
   (setq hyp2 (* hyp2 -1))
 )    
 (if (< ncos 0.0)
   (setq ncos (*(cos ang)-1))
 )
(setq npt (polar p2 ang hyp2))
 (princ (strcat "\n npt is: "(rtos(car npt)) ", " (rtos(cadr npt)) ", " "0.0")); for testing
(princ)
)

 

 

But I got lost in the trig in the end :-(

Trig.jpg

marko_ribar Veteran

marko_ribar

Posted
Posted

I am not quite sure, but test it...

 

(defun c:exttrimtoptucs ( / *adoc* *error* ucsf ss xr yr i li p1 p2 )

 (vl-load-com)
 (setq *adoc* (vla-get-activedocument (vlax-get-acad-object)))

 (defun *error* ( m )
   (if ucsf
     (command "_.UCS" "_P")
   )
   (if (entget xr)
     (entdel xr)
   )
   (if (entget yr)
     (entdel yr)
   )
   (vla-endundomark *adoc*)
   (if m
     (prompt m)
   )
   (princ)
 )

 (vla-startundomark *adoc*)
 (if (= 0 (getvar 'worlducs))
   (progn
     (command "_.UCS" "_W")
     (setq ucsf t)
   )
 )
 (prompt "\nSelect LINEs to extend/trim to picked point...")
 (cond
   ( (setq ss (ssget "_:L" '((0 . "LINE"))))
     (prompt "\nPick or specify point and choose X axis orientation : ")
     (command "_.UCS")
     (while (< 0 (getvar 'cmdactive))
       (command "\\")
     )
     (command "_.RAY" "_non" '(0.0 0.0 0.0) "_non" '(1.0 0.0 0.0) "")
     (setq xr (entlast))
     (command "_.RAY" "_non" '(0.0 0.0 0.0) "_non" '(0.0 1.0 0.0) "")
     (setq yr (entlast))
     (repeat (setq i (sslength ss))
       (setq li (ssname ss (setq i (1- i))))
       (setq p1 (vlax-invoke (vlax-ename->vla-object li) 'intersectwith (vlax-ename->vla-object xr) acextendthisentity))
       (if (null p1)
         (setq p1 (vlax-invoke (vlax-ename->vla-object li) 'intersectwith (vlax-ename->vla-object xr) acextendnone))
       )
       (setq p2 (vlax-invoke (vlax-ename->vla-object li) 'intersectwith (vlax-ename->vla-object yr) acextendthisentity))
       (if (null p2)
         (setq p2 (vlax-invoke (vlax-ename->vla-object li) 'intersectwith (vlax-ename->vla-object yr) acextendnone))
       )
       (cond
         ( (and p1 (not p2)
             (equal (distance (cdr (assoc 10 (entget li))) (cdr (assoc 11 (entget li)))) (+ (distance (cdr (assoc 10 (entget li))) p1) (distance p1 (cdr (assoc 11 (entget li))))) 1e-6)
             (> (car (trans (cdr (assoc 10 (entget li))) 0 1)) 0)
             (> (cadr (trans (cdr (assoc 10 (entget li))) 0 1)) 0)
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 11 p1) (assoc 11 (entget li)) (entget li))))))
         )
         ( (and p1 (not p2)
             (equal (distance (cdr (assoc 10 (entget li))) (cdr (assoc 11 (entget li)))) (+ (distance (cdr (assoc 10 (entget li))) p1) (distance p1 (cdr (assoc 11 (entget li))))) 1e-6)
             (> (car (trans (cdr (assoc 11 (entget li))) 0 1)) 0)
             (> (cadr (trans (cdr (assoc 11 (entget li))) 0 1)) 0)
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 10 p1) (assoc 10 (entget li)) (entget li))))))
         )
         ( (and (not p1) p2
             (equal (distance (cdr (assoc 10 (entget li))) (cdr (assoc 11 (entget li)))) (+ (distance (cdr (assoc 10 (entget li))) p2) (distance p2 (cdr (assoc 11 (entget li))))) 1e-6)
             (> (car (trans (cdr (assoc 10 (entget li))) 0 1)) 0)
             (> (cadr (trans (cdr (assoc 10 (entget li))) 0 1)) 0)
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 11 p2) (assoc 11 (entget li)) (entget li))))))
         )
         ( (and (not p1) p2
             (equal (distance (cdr (assoc 10 (entget li))) (cdr (assoc 11 (entget li)))) (+ (distance (cdr (assoc 10 (entget li))) p2) (distance p2 (cdr (assoc 11 (entget li))))) 1e-6)
             (> (car (trans (cdr (assoc 11 (entget li))) 0 1)) 0)
             (> (cadr (trans (cdr (assoc 11 (entget li))) 0 1)) 0)
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 10 p2) (assoc 10 (entget li)) (entget li))))))
         )
         ( (and p1 (not p2)
             (equal (distance (cdr (assoc 11 (entget li))) p1) (+ (distance (cdr (assoc 11 (entget li))) (cdr (assoc 10 (entget li)))) (distance (cdr (assoc 10 (entget li))) p1)) 1e-6)
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 10 p1) (assoc 10 (entget li)) (entget li))))))
         )
         ( (and p1 (not p2)
             (equal (distance (cdr (assoc 10 (entget li))) p1) (+ (distance (cdr (assoc 10 (entget li))) (cdr (assoc 11 (entget li)))) (distance (cdr (assoc 11 (entget li))) p1)) 1e-6)
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 11 p1) (assoc 11 (entget li)) (entget li))))))
         )
         ( (and (not p1) p2
             (equal (distance (cdr (assoc 11 (entget li))) p2) (+ (distance (cdr (assoc 11 (entget li))) (cdr (assoc 10 (entget li)))) (distance (cdr (assoc 10 (entget li))) p2)) 1e-6)
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 10 p2) (assoc 10 (entget li)) (entget li))))))
         )
         ( (and (not p1) p2
             (equal (distance (cdr (assoc 10 (entget li))) p2) (+ (distance (cdr (assoc 10 (entget li))) (cdr (assoc 11 (entget li)))) (distance (cdr (assoc 11 (entget li))) p2)) 1e-6)
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 11 p2) (assoc 11 (entget li)) (entget li))))))
         )
         ( (and p1 p2
             (equal (distance (cdr (assoc 11 (entget li))) p1) (+ (distance (cdr (assoc 11 (entget li))) (cdr (assoc 10 (entget li)))) (distance (cdr (assoc 10 (entget li))) p1)) 1e-6)
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 10 p1) (assoc 10 (entget li)) (entget li))))))
           (entupd (cdr (assoc -1 (entmod (subst (cons 11 p2) (assoc 11 (entget li)) (entget li))))))
         )
         ( (and p1 p2
             (equal (distance (cdr (assoc 10 (entget li))) p1) (+ (distance (cdr (assoc 10 (entget li))) (cdr (assoc 11 (entget li)))) (distance (cdr (assoc 11 (entget li))) p1)) 1e-6)
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 11 p1) (assoc 11 (entget li)) (entget li))))))
           (entupd (cdr (assoc -1 (entmod (subst (cons 10 p2) (assoc 10 (entget li)) (entget li))))))
         )
         ( (and p1 p2
             (equal (distance (cdr (assoc 11 (entget li))) p2) (+ (distance (cdr (assoc 11 (entget li))) (cdr (assoc 10 (entget li)))) (distance (cdr (assoc 10 (entget li))) p2)) 1e-6)
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 10 p2) (assoc 10 (entget li)) (entget li))))))
           (entupd (cdr (assoc -1 (entmod (subst (cons 11 p1) (assoc 11 (entget li)) (entget li))))))
         )
         ( (and p1 p2
             (equal (distance (cdr (assoc 10 (entget li))) p2) (+ (distance (cdr (assoc 10 (entget li))) (cdr (assoc 11 (entget li)))) (distance (cdr (assoc 11 (entget li))) p2)) 1e-6)
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 11 p2) (assoc 11 (entget li)) (entget li))))))
           (entupd (cdr (assoc -1 (entmod (subst (cons 10 p1) (assoc 10 (entget li)) (entget li))))))
         )
         ( (and p1 p2
             (equal (distance p1 p2) (+ (distance p1 (cdr (assoc 10 (entget li)))) (distance (cdr (assoc 10 (entget li))) p2)) 1e-6)
             (equal (distance p1 p2) (+ (distance p1 (cdr (assoc 11 (entget li)))) (distance (cdr (assoc 11 (entget li))) p2)) 1e-6)
             (< (distance (cdr (assoc 10 (entget li))) p1) (distance (cdr (assoc 11 (entget li))) p1))
             (< (distance (cdr (assoc 11 (entget li))) p2) (distance (cdr (assoc 10 (entget li))) p2))
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 10 p1) (assoc 10 (entget li)) (entget li))))))
           (entupd (cdr (assoc -1 (entmod (subst (cons 11 p2) (assoc 11 (entget li)) (entget li))))))
         )
         ( (and p1 p2
             (equal (distance p1 p2) (+ (distance p1 (cdr (assoc 10 (entget li)))) (distance (cdr (assoc 10 (entget li))) p2)) 1e-6)
             (equal (distance p1 p2) (+ (distance p1 (cdr (assoc 11 (entget li)))) (distance (cdr (assoc 11 (entget li))) p2)) 1e-6)
             (< (distance (cdr (assoc 10 (entget li))) p2) (distance (cdr (assoc 11 (entget li))) p2))
             (< (distance (cdr (assoc 11 (entget li))) p1) (distance (cdr (assoc 10 (entget li))) p1))
           )
           (entupd (cdr (assoc -1 (entmod (subst (cons 10 p2) (assoc 10 (entget li)) (entget li))))))
           (entupd (cdr (assoc -1 (entmod (subst (cons 11 p1) (assoc 11 (entget li)) (entget li))))))
         )
       )
     )
     (command "_.UCS" "_P")
   )
   ( t (prompt "\nEmpty sel.set... Retry routine next time..."))
 )
 (*error* nil)
)

 

HTH, M.R.

Regards to all '76 generation (mine too)...

Lee Mac Grand Master

Lee Mac

Posted
Posted

Try the following:

([color=BLUE]defun[/color] c:orthextrim ( [color=BLUE]/[/color] enx ept idx lst pnt sel spt vec )
   ([color=BLUE]if[/color] ([color=BLUE]and[/color] ([color=BLUE]setq[/color] sel ([color=BLUE]ssget[/color] [color=MAROON]"_:L"[/color] '((0 . [color=MAROON]"LINE"[/color]))))
            ([color=BLUE]setq[/color] pnt ([color=BLUE]getpoint[/color] [color=MAROON]"\nSpecify point: "[/color]))
       )
       ([color=BLUE]repeat[/color] ([color=BLUE]setq[/color] idx ([color=BLUE]sslength[/color] sel))
           ([color=BLUE]setq[/color] enx ([color=BLUE]entget[/color] ([color=BLUE]ssname[/color] sel ([color=BLUE]setq[/color] idx ([color=BLUE]1-[/color] idx))))
                 spt ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 10 enx))
                 ept ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 11 enx))
                 vec ([color=BLUE]mapcar[/color] '[color=BLUE]-[/color] spt ept)
           )
           ([color=BLUE]if[/color]
               ([color=BLUE]cdr[/color]
                   ([color=BLUE]setq[/color] lst
                       ([color=BLUE]vl-sort[/color]
                           ([color=BLUE]vl-remove-if[/color]
                              '([color=BLUE]lambda[/color] ( x )
                                   ([color=BLUE]or[/color] ([color=BLUE]<[/color] ([color=BLUE]car[/color]  x) ([color=BLUE]-[/color] ([color=BLUE]car[/color]  pnt) 1e-)
                                       ([color=BLUE]<[/color] ([color=BLUE]+[/color] ([color=BLUE]cadr[/color] pnt) 1e- ([color=BLUE]cadr[/color] x))
                                   )
                               )
                               ([color=BLUE]vl-list*[/color] spt ept
                                   ([color=BLUE]mapcar[/color] '([color=BLUE]lambda[/color] ( v ) ([color=BLUE]inters[/color] spt ept pnt ([color=BLUE]mapcar[/color] '[color=BLUE]+[/color] pnt v) [color=BLUE]nil[/color]))
                                       '((1 0 0) (0 -1 0))
                                   )
                               )
                           )
                          '([color=BLUE]lambda[/color] ( a b ) ([color=BLUE]<[/color] ([color=BLUE]caddr[/color] ([color=BLUE]trans[/color] a 0 vec)) ([color=BLUE]caddr[/color] ([color=BLUE]trans[/color] b 0 vec))))
                       )
                   )
               )
               ([color=BLUE]entmod[/color] ([color=BLUE]list[/color] ([color=BLUE]assoc[/color] -1 enx) ([color=BLUE]cons[/color] 10 ([color=BLUE]car[/color] lst)) ([color=BLUE]cons[/color] 11 ([color=BLUE]last[/color] lst))))
           )
       )
   )
   ([color=BLUE]princ[/color])
)

Simon1976 Explorer

Simon1976

Posted
  • Author
Posted

It seems I was barking up the wrong tree with trying to solve it through triangulation/trigonometry & a polar function. I've just tested your code Lee Mac & it works brilliantly, thank you so much. Thank you too Marko, I tried yours but it hung a couple of times.

 

 

- Simon

Happy Hobbit Collaborator

Happy Hobbit

Posted
Posted

What a good idea, unfortunately I cannot get either code to work, I'm using plain 2014. Lee's code also stops, it extends or trims one line but ignores other selected lines. In VLIDE it displays the cursor with parentheses as if waiting for AutoCAD to do something. Ditto Markos code. How did you get it working simon1976?

marko_ribar Veteran

marko_ribar

Posted
Posted

My code works for me... When hanging occurs?... Are you aware that you must provide orientation for UCS X,Y axis?... All you have to do is select lines and pick point and with second pick you provide direction of X axis (Y axis is always 90 degree CCW from X), so if you want like in picture, you should pick second point at -90 degree so that XDIR is (0 -1) and YDIR (1 0)...

Lee Mac Grand Master

Lee Mac

Posted
Posted
It seems I was barking up the wrong tree with trying to solve it through triangulation/trigonometry & a polar function. I've just tested your code Lee Mac & it works brilliantly, thank you so much. Thank you too Marko, I tried yours but it hung a couple of times.

 

- Simon

 

You're most welcome Simon, it was an interesting program to write.

Simon1976 Explorer

Simon1976

Posted
  • Author
Posted

Hello Marko

 

 

The UCS is always world & I never change it, the lisp doesn't prompt for a pickpoint to trim/extend the line to (see diagram above) & it seem to extend the lines the wrong way

marko_ribar Veteran

marko_ribar

Posted
Posted

Is it possible that no one understand the written code... I've explained how lisp works, you have to select lines and then pick 2 points (base and second for orientation of X axis)... Lisp is then constructing 2 RAY entities to which trim/extend is to be calculated... At the end UCS is returned to previous orientation and RAYs are erased leaving line entities modified (trimmed/extended) to exactly previously defined RAYs (orientation of UCS)... So it does the same as in the picture, you just need to provide correct orientation XDIR (0 -1) YDIR (1 0)... And what is more important, you can specify any other orientation for which you want to perform action and for that reason, IMHO my version is more general than Lee's...

Grrr Veteran

Grrr

Posted
Posted

Hi Simon,

I just tested Marko's code.

First you need to make a selection of your lines,

then for specifying origin point - pick the "PICKPT" in your example

then specify 2nd point, as you would create one of these imaginary lines in your example

and for the 3rd point click somewhere in the area between these 2 imaginary lines.

marko_ribar Veteran

marko_ribar

Posted
Posted

Oh yes, Grrr you're absolutely right... 3rd point is needed as acceptance...

Thanks for catch...

 

M.R.

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...