center line for two lines.

October 16, 2010

hi,all

I use the following codes to resolve center line for two lines which are intersected.but it don't work. the "if " condition seems can not be kick in.

can somebody help me.thanks.

(if (setq basePoint (inters end1 end3 end2 end4 nil))
(progn
	(print "they are inters.")
	(setq lastline (entlast))
	(entdel lastline)
	(if (< (car end1) (car end3))
		(progn
			(setq angle1 (angle end1 end3))
		);then
		(progn
			(setq angle1 (angle end3 end1))
		);else
	)
	(if (< (car end2) (car end4))
		(progn
			(setq angle2 (angle end2 end4))
		);then
		(progn
			(setq angle2 (angle end2 end4))
		);else
	)
	(setq endPoint (polar basePoint (/ (+ angle1 angle2) 2) 10))
	(command "line" basePoint endPoint "")
)
)

October 16, 2010

(if (setq basePoint (inters end1 end3 end2 end4 nil))
(progn
	(print "they are inters.")
	(setq lastline (entlast))
	(entdel lastline)
	(if (< (car end1) (car end3))
		(progn
			(setq angle1 (angle end1 end3))
		);then
		(progn
			(setq angle1 (angle end3 end1))
		);else
	)
	(if (< (car end2) (car end4))
		(progn
			(setq angle2 (angle end2 end4))
		);then
		(progn
			(setq angle2 (angle [color="red"][b]end4 end2[/b][/color]))
		);else
	)
	(setq endPoint (polar basePoint (/ (+ angle1 angle2) 2) 10))
	(command "line" basePoint endPoint "")
)
)

Why don't you post the first part that includes the selection set of lines !

October 16, 2010

it is too large.:wink:

here it is.

(defun c:drawing_center_line (/)
  ;(setvar "cmdecho" 0)
  (defun *error* (msg)
	(setvar "osmode" os_old)
  )
  (setq os_old (getvar "osmode"))
  (setq cl_old (getvar "clayer"))
  (setvar "osmode" 0)
  (command "ucs" "")
;-----------------------------------------------------------------------------------------
  (if (not (tblsearch "layer" "0centerlayer"))
      (command "_.layer" "_new" "0centerlayer" "_color" "1" "0centerlayer" "_ltype" "center" "0centerlayer" "")
      (command "_.layer" "thaw" "0centerlayer" "on" "0centerlayer" "unlock" "0centerlayer" "")
  )
;------------------------------------------------------------------------------------------
 (setq a1 (entsel "\nchoose circle\\arc\\line:"))
 (while (null a1)
      (setq a1 (entsel "\nchoose circle\\arc\\line:"))
 )
 (setq a2 (entget (car a1)))
 (setq l1 (assoc 0 a2))
 (setq l2 (cdr l1))
 (while (and (/= l2 "LINE") (/= l2 "ARC") (/= l2 "CIRCLE"))
        (setq a1 (entsel "\nthey are not circle\\arc\\lines:"))
        (while (null a1)
           (setq a1 (entsel "\nchoose circle \\arc \\ lines:"))
        )
        (setq pt1 (cadr a1))
        (setq a2 (entget (car a1)))
        (setq l1 (assoc 0 a2))
        (setq l2 (cdr l1))
 )
 (if (or (= l2 "ARC") (= l2 "CIRCLE"))
     (progn
         (setq b1 (cdr (assoc 10 a2)))  ;圆心座标
         (setq b2 (cdr (assoc 40 a2)))  ;圆半径
         (setvar "clayer" "0centerlayer")
         (command "line" (list (- (car b1) (* b2 1.1)) (cadr b1)) (strcat "@" (rtos (* b2 2.2))
                         "<0") "")
         (command "array" "l" "" "p" b1 "2" "90" "")
     )
  )
 (if (or (= l2 "LINE"))
     (progn
         (setq a3 (entsel "\nchoose another line:"))
         (while (null a3)
                (setq a3 (entsel "\nchoose another line:"))
         )
         (setq a4 (entget (car a3)))
         (setq end1 (cdr (assoc 10 a2)))
         (setq end2 (cdr (assoc 11 a2)))
         (setq end3 (cdr (assoc 10 a4)))
         (setq end4 (cdr (assoc 11 a4)))
         (setq e1 (distance end1 end3))
         (setq e2 (distance end1 end4))
         (if (< e1 e2)
            (progn
             (setq end5 (list (/ (+ (car end1) (car end3)) 2.0) (/ (+ (cadr end1) (cadr end3)) 2.0)))
             (setq end6 (list (/ (+ (car end2) (car end4)) 2.0) (/ (+ (cadr end2) (cadr end4)) 2.0)))
            )
            (progn
             (setq end5 (list (/ (+ (car end1) (car end4)) 2.0) (/ (+ (cadr end1) (cadr end4)) 2.0)))
             (setq end6 (list (/ (+ (car end2) (car end3)) 2.0) (/ (+ (cadr end2) (cadr end3)) 2.0)))
            )
         )
	  ;(if inters( end1 end3 end2 end4) (print "they are inters."))
         (setq end5_1 (polar end5 (angle end6 end5) 10))
         (setq end6_1 (polar end6 (angle end5 end6) 10))

         (setvar "clayer" "0centerlyaer")
         (command "line" end5_1 end6_1 "")
	  (if (setq basePoint (inters end1 end3 end2 end4 nil))
		(progn
			(print "they are inters.")
			(setq lastline (entlast))
			(entdel lastline)
			(if (< (car end1) (car end3))
				(progn
					(setq angle1 (angle end1 end3))
				);then
				(progn
					(setq angle1 (angle end3 end1))
				);else
			)
			(if (< (car end2) (car end4))
				(progn
					(setq angle2 (angle end2 end4))
				);then
				(progn
					(setq angle2 (angle end2 end4))
				);else
			)
			(setq endPoint (polar basePoint (/ (+ angle1 angle2) 2) 10))
			(command "line" basePoint endPoint "")
		)
	  )
     )
  )
  (setvar "osmode" os_old)
  (setvar "clayer" cl_old)
  (princ)
)

October 16, 2010

They work for circle arc and lines which are parallel but not intersected.

October 16, 2010

What's the main issue of your routine ?

Or draw a line between two crossing lines or parallel lines ?

October 16, 2010

the center line it draw for crossing lines was wrong.it was not angle center line.

so I added the following codes to fix it. but it failed.the "if" condition can not be kicked in.

I can not figure out what is going on.

(if (setq basePoint (inters end1 end3 end2 end4 nil))
(progn
	(print "they are inters.")
	(setq lastline (entlast))
	(entdel lastline)
	(if (< (car end1) (car end3))
		(progn
			(setq angle1 (angle end1 end3))
		);then
		(progn
			(setq angle1 (angle end3 end1))
		);else
	)
	(if (< (car end2) (car end4))
		(progn
			(setq angle2 (angle end2 end4))
		);then
		(progn
			(setq angle2 (angle end4 end2))
		);else
	)
	(setq endPoint (polar basePoint (/ (+ angle1 angle2) 2) 10))
	(command "line" basePoint endPoint "")
)
)

October 16, 2010

The breakdown is in the following codes , check once again , and I will be back.

Sorry, I have to go right now.

(if (< (car end1) (car end3))
;---------------------
(if (< (car end2) (car end4))

Regards,

Tharwat

October 16, 2010

after some debug .I found that function inters cause the issue.

e.g.

!end1

(1698.78 1117.78 0.0)

!end2

(2051.59 877.881 0.0)

!end3

(1484.85 881.629 0.0)

!end4

(1954.01 817.907 0.0)

but inters return the wrong crossing point.

(inters end1 end3 end2 end4 nil)

(765.244 87.3106 0.0)

October 16, 2010

here is the update codes.it draw something but wrong.

(defun c:dd (/)
  ;(setvar "cmdecho" 0)
  (defun *error* (msg)
	(setvar "osmode" os_old)
  )
  (setq os_old (getvar "osmode"))
  (setq cl_old (getvar "clayer"))
  (setvar "osmode" 0)
  (command "ucs" "")
;-----------------------------------------------------------------------------------------
  (if (not (tblsearch "layer" "0中心线层"))
      (command "_.layer" "_new" "0中心线层" "_color" "1" "0中心线层" "_ltype" "center" "0中心线层" "")
      (command "_.layer" "thaw" "0中心线层" "on" "0中心线层" "unlock" "0中心线层" "")
  )
;------------------------------------------------------------------------------------------
 (setq a1 (entsel "\n请选定要画中心线的圆\\圆弧\\直线:"))
 (while (null a1)
      (setq a1 (entsel "\n请选定要画中心线的圆\\圆弧\\直线:"))
 )
 (setq a2 (entget (car a1)))
 (setq l1 (assoc 0 a2))
 (setq l2 (cdr l1))
 (while (and (/= l2 "LINE") (/= l2 "ARC") (/= l2 "CIRCLE"))
        (setq a1 (entsel "\n所选的不是圆\\圆弧\\直线:"))
        (while (null a1)
           (setq a1 (entsel "\n请选定要画中心线的圆\\圆弧\\直线:"))
        )
        (setq pt1 (cadr a1))
        (setq a2 (entget (car a1)))
        (setq l1 (assoc 0 a2))
        (setq l2 (cdr l1))
 )
 (if (or (= l2 "ARC") (= l2 "CIRCLE"))
     (progn
         (setq b1 (cdr (assoc 10 a2)))  ;圆心座标
         (setq b2 (cdr (assoc 40 a2)))  ;圆半径
         (setvar "clayer" "0中心线层")
         (command "line" (list (- (car b1) (* b2 1.1)) (cadr b1)) (strcat "@" (rtos (* b2 2.2))
                         "<0") "")
         (command "array" "l" "" "p" b1 "2" "90" "")
     )
  )
 (if (or (= l2 "LINE"))
     (progn
         (setq a3 (entsel "\n请选定另一直线:"))
         (while (null a3)
                (setq a3 (entsel "\n请选定另一直线:"))
         )
         (setq a4 (entget (car a3)))
         (setq end1 (cdr (assoc 10 a2)))
         (setq end2 (cdr (assoc 11 a2)))
         (setq end3 (cdr (assoc 10 a4)))
         (setq end4 (cdr (assoc 11 a4)))
         (setq e1 (distance end1 end3))
         (setq e2 (distance end1 end4))
         (if (< e1 e2)
            (progn
             (setq end5 (list (/ (+ (car end1) (car end3)) 2.0) (/ (+ (cadr end1) (cadr end3)) 2.0)))
             (setq end6 (list (/ (+ (car end2) (car end4)) 2.0) (/ (+ (cadr end2) (cadr end4)) 2.0)))
            )
            (progn
             (setq end5 (list (/ (+ (car end1) (car end4)) 2.0) (/ (+ (cadr end1) (cadr end4)) 2.0)))
             (setq end6 (list (/ (+ (car end2) (car end3)) 2.0) (/ (+ (cadr end2) (cadr end3)) 2.0)))
            )
         )
	  ;(if inters( end1 end3 end2 end4) (print "they are inters."))
         (setq end5_1 (polar end5 (angle end6 end5) 10))
         (setq end6_1 (polar end6 (angle end5 end6) 10))

         (setvar "clayer" "0中心线层")
         (command "line" end5_1 end6_1 "")
	  (if (setq basePoint (inters end1 end3 end2 end4 nil))
	  ;(if basePoint
		(progn
			(print "they are inters.")
			(setq lastline (entlast))
			(entdel lastline)
			(if (< (cadr end1) (cadr end2))
				(progn
					(setq angle1 (angle end1 end2))
				);then
				(progn
					(setq angle1 (angle end2 end1))
				);else
			)
			(if (< (cadr end3) (cadr end4))
				(progn
					(setq angle2 (angle end3 end4))
				);then
				(progn
					(setq angle2 (angle end4 end3))
				);else
			)
			(setq endPoint (polar basePoint (/ (+ angle1 angle2) 2) 10))
			(command "line" basePoint endPoint "")
		)
	  )
     )
  )
  (setvar "osmode" os_old)
  (setvar "clayer" cl_old)
  (princ)
)

October 16, 2010

Hi,

I'm not sure what you are aiming for with the lines, but for Arcs, Circles or Ellipses, here is an old one that I wrote:

(defun c:cl ( / e a d p1 p2 )
 (vl-load-com)
 ;; Lee Mac 2010

 (if (and
       (setq e
         (LM:Selectif
           (lambda ( e )
             (member (cdr (assoc 0 (entget e))) '("CIRCLE" "ARC" "ELLIPSE"))
           )
           entsel "\nSelect Arc, Circle or Ellipse: "
         )
       )
       (setq p2
         (getpoint (setq p1 (trans (cdr (assoc 10 (entget e))) e 1))
           "\nSpecify Length of Centreline: "
         )
       )
     )
   (progn (setq a (angle p1 p2) d (distance p1 p2))
     (mapcar
       (function
         (lambda ( a d )
           (entmakex
             (list
               (cons 0 "LINE")
               (cons 10 (trans (polar p1 a d) 1 0))
               (cons 11 (trans (polar p1 a (- d)) 1 0))
             )
           )
         )
       )
       (list a (+ a (/ pi 2.))) (list d (- d))
     )
   )
 )
 (princ)
)

;;---------------------=={ Select if }==----------------------;;
;;                                                            ;;
;;  Continuous selection prompts until the predicate function ;;
;;  foo is validated                                          ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  foo - optional predicate function taking ename argument   ;;
;;  fun - selection function to invoke                        ;;
;;  str - prompt string                                       ;;
;;------------------------------------------------------------;;
;;  Returns:  selected entity ename if successful, else nil   ;;
;;------------------------------------------------------------;;

(defun LM:Selectif ( foo fun str / e )
 ;; © Lee Mac 2010
 (while
   (progn (setq e (car (fun str)))      
     (cond
       ( (eq 'ENAME (type e))

         (if (and foo (not (foo e))) (princ "\n** Invalid Object Selected **"))
       )
     )
   )
 )
 e
)

October 16, 2010

hi,lee,what I want to do is to drawing angle center line for two crossing lines.as the picture described.

October 16, 2010

OK, I understand

October 16, 2010

If you are looking for 2 LINEs only, then this may work:

[b][color=BLACK]([/color][/b]defun c:ang-cl [b][color=FUCHSIA]([/color][/b]/ l1 l2 d1 d2 p10 p11 p20 p21
                  e1 e2 a1 a2 ipt mpt ss[b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]while [b][color=NAVY]([/color][/b]or [b][color=MAROON]([/color][/b]not ss[b][color=MAROON])[/color][/b]
            [b][color=MAROON]([/color][/b]/= [b][color=GREEN]([/color][/b]sslength ss[b][color=GREEN])[/color][/b] 2[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
        [b][color=NAVY]([/color][/b]princ [color=#2f4f4f]"\nSelect 2 Intersecting LINEs:   "[/color][b][color=NAVY])[/color][/b]
        [b][color=NAVY]([/color][/b]setq ss [b][color=MAROON]([/color][/b]ssget '[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=FUCHSIA])[/color][/b]

 [b][color=FUCHSIA]([/color][/b]setq l1 [b][color=NAVY]([/color][/b]ssname ss 0[b][color=NAVY])[/color][/b] d1 [b][color=NAVY]([/color][/b]entget l1[b][color=NAVY])[/color][/b]
       l2 [b][color=NAVY]([/color][/b]ssname ss 1[b][color=NAVY])[/color][/b] d2 [b][color=NAVY]([/color][/b]entget l2[b][color=NAVY])[/color][/b]
      p10 [b][color=NAVY]([/color][/b]cdr [b][color=MAROON]([/color][/b]assoc 10 d1[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b] p11 [b][color=NAVY]([/color][/b]cdr [b][color=MAROON]([/color][/b]assoc 11 d1[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
      p20 [b][color=NAVY]([/color][/b]cdr [b][color=MAROON]([/color][/b]assoc 10 d2[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b] p21 [b][color=NAVY]([/color][/b]cdr [b][color=MAROON]([/color][/b]assoc 11 d2[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
      ipt [b][color=NAVY]([/color][/b]inters p10 p11 p20 p21 nil[b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]

 [b][color=FUCHSIA]([/color][/b]if ipt
   [b][color=NAVY]([/color][/b]progn
    [b][color=MAROON]([/color][/b]setq a1 [b][color=GREEN]([/color][/b]angle p10 p11[b][color=GREEN])[/color][/b] a2 [b][color=GREEN]([/color][/b]angle p20 p21[b][color=GREEN])[/color][/b]
          e1 [b][color=GREEN]([/color][/b]if [b][color=BLUE]([/color][/b]> [b][color=RED]([/color][/b]distance ipt p10[b][color=RED])[/color][/b] [b][color=RED]([/color][/b]distance ipt p11[b][color=RED])[/color][/b][b][color=BLUE])[/color][/b] p10 p11[b][color=GREEN])[/color][/b]
          e2 [b][color=GREEN]([/color][/b]if [b][color=BLUE]([/color][/b]> [b][color=RED]([/color][/b]distance ipt p20[b][color=RED])[/color][/b] [b][color=RED]([/color][/b]distance ipt p21[b][color=RED])[/color][/b][b][color=BLUE])[/color][/b] p20 p21[b][color=GREEN])[/color][/b]
          e2 [b][color=GREEN]([/color][/b]polar ipt [b][color=BLUE]([/color][/b]angle ipt e2[b][color=BLUE])[/color][/b] [b][color=BLUE]([/color][/b]distance ipt e1[b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b]
         mpt [b][color=GREEN]([/color][/b]inters [b][color=BLUE]([/color][/b]polar ipt [b][color=RED]([/color][/b]angle ipt e1[b][color=RED])[/color][/b] [b][color=RED]([/color][/b]distance ipt e1[b][color=RED])[/color][/b][b][color=BLUE])[/color][/b] e2
                     [b][color=BLUE]([/color][/b]polar ipt [b][color=RED]([/color][/b]+ [b][color=PURPLE]([/color][/b]angle e1 e2[b][color=PURPLE])[/color][/b] [b][color=PURPLE]([/color][/b]* pi 0.5[b][color=PURPLE])[/color][/b][b][color=RED])[/color][/b] 1[b][color=BLUE])[/color][/b] ipt nil[b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b]
    [b][color=MAROON]([/color][/b]entmake [b][color=GREEN]([/color][/b]list [b][color=BLUE]([/color][/b]cons 0 [color=#2f4f4f]"LINE"[/color][b][color=BLUE])[/color][/b]
                   [b][color=BLUE]([/color][/b]cons 10 ipt[b][color=BLUE])[/color][/b]
                   [b][color=BLUE]([/color][/b]cons 11 mpt[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]alert [color=#2f4f4f]"\nLINEs Do Not Intertsect - Aborting"[/color][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]

Watch out for 3D lines. -David

October 16, 2010

Perhaps there's a better way to do this, but this should handle parallel's too:

( Removed, only worked for parallel lines... oops! )

Edited October 16, 2010 by Lee Mac

October 16, 2010

Another, using inters:

(defun c:test ( / _permute ip s1 s2 e1 e2 )
 ;; © Lee Mac 2010
   
 (defun _permute ( a b )
   (set 'c (eval a))
   (set  a (eval b))
   (set  b c)
 )

 (if
   (and
     (setq e1 (car (entsel "\nFirst Line: ")))
     (eq "LINE" (cdr (assoc 0 (entget e1))))
     (setq e2 (car (entsel "\nSecond Line: ")))
     (eq "LINE" (cdr (assoc 0 (entget e2))))    

     (progn
       (mapcar 'set '(s1 s2 e1 e2)
         (mapcar '(lambda ( x e ) (cdr (assoc x (entget e)))) '(10 10 11 11) (list e1 e2 e1 e2))
       )
       (setq ip (inters s1 e1 s2 e2 nil))
     )
   )
   (progn
     (if (< (distance ip e1) (distance ip s1)) (_permute 's1 'e1))
     (if (< (distance ip e2) (distance ip s2)) (_permute 's2 'e2))
     
     (entmakex
       (list
         (cons 0 "LINE")
         (cons 10 ip)
         (cons 11 (polar ip (+ pi (/ (+ (angle s1 e1) (angle s2 e2)) 2.)) 1.))
       )
     )
   )
 )

 (princ)
)

Edited October 19, 2010 by Lee Mac

October 16, 2010

A somewhat more 'traditional' way....

(defun c:bisect ( / _GroupByNum _Inters _Circle _Line e1 e2 o1 o2 ip )
 (vl-load-com)
 ;; © Lee Mac 2010

 (defun _GroupByNum ( l n / r)
   (setq r (list (car l)))
 
   (if l
     (cons
       (reverse
         (repeat (1- n) (setq l (cdr l) r (cons (car l) r)))
       )
       (_GroupByNum (cdr l) n)
     )
   )
 )

 (defun _inters ( obj1 obj2 )
   (_GroupByNum (vlax-invoke obj1 'IntersectWith obj2 acExtendNone) 3)
 )

 (defun _Circle ( c r )
   (entmakex (list (cons 0 "CIRCLE") (cons 10 c) (cons 40 r) (cons 62 252)))
 )

 (defun _Line ( p q )
   (entmakex (list (cons 0 "LINE") (cons 10 p) (cons 11 q)))
 )

 (if
   (and
     (setq e1 (car (entsel "\nFirst Line: ")))
     (eq "LINE" (cdr (assoc 0 (entget e1))))
     (setq e2 (car (entsel "\nSecond Line: ")))
     (eq "LINE" (cdr (assoc 0 (entget e2))))
     (setq ip (_inters (setq o1 (vlax-ename->vla-object e1))
                       (setq o2 (vlax-ename->vla-object e2)))
     )
   )
   (_Line (car ip)
     (car
       (vl-remove-if
         (function
           (lambda ( x )
             (equal (car ip) x 1e-
           )
         )
         (apply '_inters
           (mapcar
             (function
               (lambda ( c )
                 (vlax-ename->vla-object (_Circle c 1.0))
               )
             )
             (vl-remove-if
               (function
                 (lambda ( x )
                   (equal (car ip) x 1e-
                 )
               )
               (append
                 (_inters (setq c1 (vlax-ename->vla-object (_Circle (car ip) 1.0))) o1)
                 (_inters c1 o2)
               )
             )
           )
         )
       )
     )
   )
 )

 (princ)
)

October 16, 2010

Another, using inters:

(defun c:test ( / s1 s2 e1 e2 bi )
 ;; © Lee Mac 2010
)

Lee, I get a lot funky results with this one..... -David

test.dwg

October 16, 2010

Lee, I get a lot funky results with this one..... -David

Thanks David, I'll check it out

October 16, 2010

Code updated, hopefull this will fix the issue

October 16, 2010

Just for fun

(defun c:bisect ( / _GroupByNum _inters _Circle _Line e o1 o2 ip c1 p1 c2 c3 li le gr cp lst ep )
 (vl-load-com)
 ;; © Lee Mac 2010

 (defun _GroupByNum ( l n / r)
   (setq r (list (car l)))
 
   (if l
     (cons
       (reverse
         (repeat (1- n) (setq l (cdr l) r (cons (car l) r)))
       )
       (_GroupByNum (cdr l) n)
     )
   )
 )
 
 (defun _inters ( obj1 obj2 )
   (_GroupByNum (vlax-invoke obj1 'IntersectWith obj2 acExtendNone) 3)
 )

 (defun _Circle ( c r )
   (entmakex (list (cons 0 "CIRCLE") (cons 10 c) (cons 40 r) (cons 62 252)))
 )

 (defun _Line ( p q )
   (entmakex (list (cons 0 "LINE") (cons 10 p) (cons 11 q) (cons 62 134)))
 )

 (if (setq e
       (LM:Selectif
         (lambda ( x )
           (eq "LINE" (cdr (assoc 0 (entget x))))
         )
         entsel "\nSelect Line: "
       )
     )
   (progn
     (setq o1 (vlax-ename->vla-object e)
           o2 (vla-copy o1)
           ip (vlax-get o1 'StartPoint)
           le (vla-get-Length o1)
           c1 (vlax-ename->vla-object (_Circle ip (setq r (* 0.25 le))))
           p1 (polar ip (angle ip (vlax-get o1 'EndPoint)) r)
           c2 (vlax-ename->vla-object (_Circle p1 r))
           c3 (vla-copy c2)
           li (entget (_Line ip p1))
     )

     (while (and (= 5 (car (setq gr (grread 't 13 0)))) (listp (setq cp (cadr gr))))
       (setq p2 (polar ip (angle ip cp) r))
       
       (vlax-put-property c3 'Center   (vlax-3D-point p2))
       (vlax-put-property o2 'EndPoint (vlax-3D-point (polar ip (angle ip cp) le)))

       (if (setq ep
             (car
               (vl-remove-if
                 (function
                   (lambda ( x ) (equal x ip 1e-)
                 )
                 (_inters c2 c3)
               )
             )
           )
         (entupd
           (cdr
             (assoc -1
               (entmod
                 (subst (cons 11 (polar ip (angle ip ep) le)) (assoc 11 li) li)
               )
             )
           )
         )
       )
     )
   )
 )

 (princ)
)

;;---------------------=={ Select if }==----------------------;;
;;                                                            ;;
;;  Continuous selection prompts until the predicate function ;;
;;  foo is validated                                          ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  foo - optional predicate function taking ename argument   ;;
;;  fun - selection function to invoke                        ;;
;;  str - prompt string                                       ;;
;;------------------------------------------------------------;;
;;  Returns:  selected entity ename if successful, else nil   ;;
;;------------------------------------------------------------;;

(defun LM:Selectif ( foo fun str / e )
 ;; © Lee Mac 2010
 (while
   (progn (setq e (car (fun str)))      
     (cond
       ( (eq 'ENAME (type e))

         (if (and foo (not (foo e)))
           (princ "\n** Invalid Object Selected **")
         )
       )
     )
   )
 )
 e
)

Sign In

center line for two lines.

Recommended Posts

blueshake

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Posted Images

Tharwat

blueshake

blueshake

Tharwat

blueshake

Tharwat

blueshake

blueshake

Lee Mac

blueshake

Lee Mac

David Bethel

Lee Mac

Lee Mac

Lee Mac

David Bethel

Lee Mac

Lee Mac

Lee Mac

Join the conversation

Tutorials

Forums

Activity