Choose midpoint and endpoint draw line.

May 7, 2014

Have such a routine ？

May 7, 2014

I have this version :

(defun c:mlp ( / p1 p2 l ll p1p p2p a loop g p pp ppp10 pp11 ppp11 )
 (setq p1 (trans (getpoint "\nPick start point") 1 0))
 (setq p2 (trans (getpoint "\nPick end point" (trans p1 0 1)) 1 0))
 (setq l (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2))))
 (setq ll (entget l))
 (setq ll (subst (cons 10 (mapcar '- p1 (mapcar '- p2 p1))) (assoc 10 ll) ll))
 (entmod ll)
 (entupd l)
 (prompt "\nENTER - continue stretching; ESC - keep drawn line")
 (getstring)
 (setq p1p (list (car (trans p1 0 1)) (cadr (trans p1 0 1)) 0.0))
 (setq p2p (list (car (trans p2 0 1)) (cadr (trans p2 0 1)) 0.0))
 (setq a (angle p1p p2p))
 (setq loop t)
 (while loop
   (setq g (grread t 15 0))
   (if (eq (car g) 5)
     (progn
       (setq p (cadr g))
       (setq pp11 (inters p1p p2p p (polar p (+ a (* 0.5 pi)) 1.0) nil))
       (setq ppp11 (inters (trans p1 0 1) (trans p2 0 1) pp11 (mapcar '+ pp11 '(0.0 0.0 1.0)) nil))
       (setq ppp10 (mapcar '- (trans p1 0 1) (mapcar '- (trans ppp11 0 1) (trans p1 0 1))))
       (setq ll (subst (cons 10 (trans ppp10 1 0)) (assoc 10 ll) ll))
       (setq ll (subst (cons 11 (trans ppp11 1 0)) (assoc 11 ll) ll))
       (entmod ll)
       (entupd l)
       (redraw)
     )
     (setq loop nil)
   )
 )
 (princ)
)

HTH, M.R.

May 7, 2014

To go with Dynamic graphic you will loose the snap objects , so here it goes below

(defun c:Test (/ c g 1p a d)
 ;;    Tharwat .7.May.2014        ;;
 (if (setq c (getpoint "\n Specify Midpoint :"))
   (while (eq (car (setq g (grread t 15 0))) 5)
     (redraw)
     (grvecs (list -3
                   c
                   (setq 1p (polar c
                                   (setq a (angle c (cadr g)))
                                   (setq d (distance c (cadr g)))
                            )
                   )
                   1p
                   (setq 2p (polar 1p (+ a pi) (* d 2.)))
             )
     )
   )
 )
 (if (eq (car g) 3)
   (entmake (list '(0 . "LINE") (cons 10 1p) (cons 11 2p)))
 )
 (redraw)
 (princ)
)

May 7, 2014

If you want snaps with (grread), maybe try this :

(defun c:mlpp ( / *error* _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho as ape osm g p1 p2 p3 p0 o p s len nlen )

 (vl-load-com)

 (defun *error* ( msg )
   (if ape (setvar 'aperture ape))
   (if as (setvar 'autosnap as))
   (if osm (setvar 'osmode osm))
   (if msg (prompt msg))
   (princ)
 )

 (defun _acapp nil
     (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
     (_acapp)
 )

 (defun _getosmode ( os / lst )
     (foreach mode
        '(
             (0001 . "_end")
             (0002 . "_mid")
             (0004 . "_cen")
             (0008 . "_nod")
             (0016 . "_qua")
             (0032 . "_int")
             (0064 . "_ins")
             (0128 . "_per")
             (0256 . "_tan")
             (0512 . "_nea")
             (1024 . "_qui")
             (2048 . "_app")
             (4096 . "_ext")
             (8192 . "_par")
         )
         (if (not (zerop (logand (car mode) os)))
             (setq lst (cons "," (cons (cdr mode) lst)))
         )
     )
     (apply 'strcat (cdr lst))
 )

 (defun _grX ( p s c / -s r j )
     (setq -s (- s)
            r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
            j p
     )
     (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
     (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
     (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
     (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
     (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
     (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

     p
 )

 (defun _OLE->ACI ( c )
     (apply '_RGB->ACI (_OLE->RGB c))
 )

 (defun _OLE->RGB ( c )
     (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 )
 )

 (defun _RGB->ACI ( r g b / c o )
     (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
         (progn
             (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
             (vlax-release-object o)
             (if (vl-catch-all-error-p c)
                 (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                 c
             )
         )
     )
 )

 (defun _snap ( p osm )
   (if (osnap p (_getosmode osm))
     (osnap p (_getosmode osm))
     p
   )
 )

 (defun _polarangs ( ang / n k a l )
   (if (/= ang 0.0)
     (progn
       (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
       (setq k -1.0)
       (repeat (1+ (fix n))
         (setq a (* (setq k (1+ k)) ang))
         (setq l (cons a l))
       )
       l
     )
     (list 0.0)
   )
 )

 (defun _polar ( p0 p flag ang / a b an )
   (if flag
     (progn
       (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
       (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
       (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
       (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
     )
     p
   )
 )

 (defun _ortho ( p0 p flag )
   (if flag
     (_polar p0 p t (* 0.5 pi))
     p
   )
 )

 (setq p1 (getpoint "\nPick or specify mid point : "))
 (setvar 'orthomode 1)
 (setq ape (getvar 'aperture))
 (setvar 'aperture 40)
 (setq as (getvar 'autosnap))
 (setvar 'autosnap 31)
 (setq osm (getvar 'osmode))
 (setvar 'osmode 15359)
 (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
 (if (eq (logand (getvar 'autosnap)  8) (setq p t) (setq p nil))
 (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
 (while (not (or (eq (car (setq g (grread t 15 0))) 3) (eq (car g) 25) (eq (car g) 11)))
   (redraw)
   (if (listp (cadr g)) (setq p2 (cadr g) p3 (cadr g)))
   (cond 
     ( (eq (cadr g) 15)
       (if (eq o t) (setq o nil) (setq o t))
     )
     ( (eq (cadr g) 21)
       (if (eq p t) (setq p nil) (setq p t))
     )
     ( (eq (cadr g) 6)
       (if (eq s t) (setq s nil) (setq s t))
     )
   )
   (cond
     ( (and o p s)
       (setq p2 (_snap (_ortho p1 p2 t) (getvar 'osmode)))
     )
     ( (and o (not p) s)
       (setq p2 (_snap (_ortho p1 p2 t) (getvar 'osmode)))
     )
     ( (and (not o) p s)
       (setq p2 (_snap (_polar p1 p2 t (getvar 'polarang)) (getvar 'osmode)))
     )
     ( (and (not o) (not p) s)
       (setq p2 (_snap p2 (getvar 'osmode)))
     )
     ( (and o p (not s))
       (setq p2 (_ortho p1 p2 t))
     )
     ( (and o (not p) (not s))
       (setq p2 (_ortho p1 p2 t))
     )
     ( (and (not o) p (not s))
       (setq p2 (_polar p1 p2 t (getvar 'polarang)))
     )
     ( (and (not o) (not p) (not s))
       (setq p2 p2)
     )
   )
   (if (not (equal p2 p3 1e-6))
     (_grX p2 (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
   )
   (setq p0 (mapcar '- p1 (mapcar '- p2 p1)))
   (grdraw p0 p2 1 1)
 )
 (entmake (list '(0 . "LINE") (cons 10 (trans p0 1 0)) (cons 11 (trans p2 1 0))))
 (setq len (distance p0 p2))
 (prompt (strcat "\nCurrent length is : " (rtos len 2 15)))
 (initget 6)
 (setq nlen (getdist (strcat "\nPick or specify new length <" (rtos len 2 15) "> : ")))
 (if nlen (command "_.scale" (entlast) "" "_non" p1 "_R" len nlen))  
 (redraw)
 (*error* nil)
)

HTH, M.R.

Edited May 31, 2014 by marko_ribar
code changed a little

May 8, 2014

To go with Dynamic graphic you will loose the snap objects , so here it goes below
[ATTACH=CONFIG]48721[/ATTACH]

Thank your Tharwat, nice code. but

1. can't input the line length.

2.Can't switch Ortho and Polar.

Edited May 8, 2014 by highflybird

May 8, 2014

If you want snaps with (grread), maybe try this :

HTH, M.R.

Thank you marko, There are three problems.

1. only use ortho mode.

2.Will be automatically cancelled “Autosnap settings”.

3. Can't input Line length.

May 8, 2014

Thank you marko, There are three problems.
1. Only use ortho mode.

2. Will be automatically cancelled “Autosnap settings”.

[ATTACH=CONFIG]48733[/ATTACH]

3. Can't input Line length.

1. You can switch orthomode on or off with F8 key, with F10 you can switch polar tracking on or off, with F3 you can switch osnaps on or off...

2. I don't understand this - Just check that (logand (getvar 'autosnap) =8 and (logand (getvar 'autosnap) 16)=16... If that's the case, then you comment out line (setvar 'autosnap 31)

3. Yes, you can't enter length as this codes uses (grread) to obtain end points...

M.R.

May 8, 2014

Hi ,Tharwat and marko, Thanks, I really need this （enter line length ）,I hope you can optimize it for me. can Osnap , can Enter.

May 8, 2014

I've modified my last code to accept input of length... I hope this will help you now...

M.R.

May 8, 2014

I've modified my last code to accept input of length... I hope this will help you now...

M.R.

Thank you for your hard work, marko, but when witch Polar , must press F10+F8 ,

I got used to ……

May 8, 2014

I used marko_ribar's code yesterday right after it was posted and I was able to enter a line length. What I had to keep in mind though was if I wanted a total line length of 8,8 I had to input 4,4. Just tested a minute ago and it worked.

In the future when requesting a lisp program please provide ALL the necessary criteria the program needs to meet up front. It will save time and headaches.

May 8, 2014

If you don't want routine to start with turned on polar+ortho+snaps, change this :

...
 (setq p1 (getpoint "\nPick or specify mid point : "))
 (setvar 'orthomode [color=red]1[/color])
 (setq ape (getvar 'aperture))
 (setvar 'aperture 40)
 (setq as (getvar 'autosnap))
 (setvar 'autosnap [color=red]31[/color])
 (setq osm (getvar 'osmode))
 (setvar 'osmode 15359)
...

To this :

...
 (setq p1 (getpoint "\nPick or specify mid point : "))
 (setvar 'orthomode [color=red]0[/color])
 (setq ape (getvar 'aperture))
 (setvar 'aperture 40)
 (setq as (getvar 'autosnap))
 (setvar 'autosnap [color=red]7[/color])
 (setq osm (getvar 'osmode))
 (setvar 'osmode 15359)
...

M.R.

Edited May 31, 2014 by marko_ribar

May 8, 2014

If you don't want routine to start with turned on polar+ortho+snaps, change this :

M.R.

Sorry ,marko, I'm not want routine to start with turned on polar+ortho+snaps,

I want switch Ortho and Polar with mouse.

NOW, must use F3 switch Osnap, Use F8+F10 switch Ortho&Polar. Unaccustomed！

May 8, 2014

This sounds like a case of "don't give me what I ask for, give me what I need." Sometimes your "requests" don't come across so clear.

May 8, 2014

This sounds like a case of "don't give me what I ask for, give me what I need." Sometimes your "requests" don't come across so clear.

I've been watching this thread with a little bit of interest. It looked to me that the solution actually as stated in post 1 was supplied pretty quickly.

May 8, 2014

The solution matched what the OP asked for. I agree. Then the OP started changing his mind. So the game is the same it's just that the rules are different?

May 8, 2014

the big question is, would thay have offered a different solution earier had all the facts been given initially?

May 9, 2014

I've been watching this thread with a little bit of interest. It looked to me that the solution actually as stated in post 1 was supplied pretty quickly.

Thank you for your attention and help! Dave,

BTW, "The OP started changing his mind" NO, is not that, I think is I don't express a clear. sorry for that !

May 9, 2014

Sometimes requests for code are not thought out to their logical conclusion forcing us to backtrack and change direction.

May 9, 2014

Sometimes requests for code are not thought out to their logical conclusion forcing us to backtrack and change direction.

Sometimes that's the case, other times it seems the OP is baiting the hook, then keeps moving the bar to get their truly desired code.

Sign In

Choose midpoint and endpoint draw line.

Recommended Posts

highflybird

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Posted Images

marko_ribar

Tharwat

marko_ribar

highflybird

highflybird

marko_ribar

highflybird

marko_ribar

highflybird

ReMark

marko_ribar

highflybird

ReMark

dbroada

ReMark

dbroada

highflybird

ReMark

Snownut

Join the conversation

Tutorials

Forums

Activity