Jump to content

connecting the last lines !HELP!

GroundWolf61

By GroundWolf61
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

GroundWolf61 Rookie

GroundWolf61

Posted
Posted

Hi everyone,

 

the firts part works fine but i cant figger out how to connect the result lines.

I have tried dis. 0 chamfering but at some angles it doesnt connect the right way.

Is there a different or better way  to connect these lines (closed polyline).

 

i know the snaps should be off but i didnt added that part or an error catcher will come later. :)

 

THX,

GW61

  

(defun C:fund ( / )
;------------------------------------------------------------;
	(setq ent (entsel))
	(setq dik (* -1 (getreal "Thickness: ")))
	(setq BRR (getreal "Extra offset: "))
	(setq BRl (* -1 BRR))
	(setq 	MyPline (vlax-ename->vla-object (car ent))
			startpt (vlax-curve-getStartPoint MyPline)
			endpt (vlax-curve-getEndPoint MyPline)
	);end setq
;------------------------------------------------------------;
	(if (< (car startpt) (car endpt))
		(progn
			(setq Tleft startpt)
			(setq Tright endpt)
		);end progn
		(progn
			(setq Tleft endpt)
			(setq Tright startpt)
		);end progn
	);end if
;------------------------------------------------------------;	
	(setq Bleft (XYZchange Tleft 0 dik 0))
	(setq Bright (XYZchange Tright 0 dik 0))
	(command "copy" ent "" tleft bleft)
	(setq entb (entlast))
;------------------------------------------------------------;	
	(setq 
		toleft	(XYZchange tleft brl 0 0)
		toright	(XYZchange tright brr 0 0)
		boleft 	(XYZchange bleft brl 0 0)
		boright	(XYZchange bright brr 0 0)
	);end setq
	(command "line" toleft boleft "")
	(setq entl (entlast))
	(command "line" toright boright "")
	(setq entr (entlast))
;------------------------------------------------------------;	
	;(command "chamfer" "d" 0 0 tleft boleft)
	;(command "chamfer" "d" 0 0 tright boright)
	;(command "chamfer" "d" 0 0 bleft entl)
	;(command "chamfer" "d" 0 0 bright entr)
);end defun fund



(defun XYZchange ( XYZ x y z / nx ny nz )
	(setq 	
		nX (+ x (car  XYZ))
		nY (+ y (cadr XYZ))
		nZ (+ z (caddr XYZ))
	);end setq
	(list nx ny nz)
);end defun XYZchange
Steven P Grand Master

Steven P

Posted
Posted

I am going to send you off in another direction completely (just because)....Lee Mac has a Double Extend routine (http://lee-mac.com/doubleextend.html) which you could modify to extend the initial line, offset that and then just draw lines between the 4 end points. If the first 2 lines are just offset from each other then both ends A and ends B will line up?

 

Half a days holiday so not much time to look at your LISP just now but above could work if you are really stuck

  • Like 1
  • Thanks 1
Steven P Grand Master

Steven P

Posted
Posted (edited)
49 minutes ago, Steven P said:

I am going to send you off in another direction completely (just because)....Lee Mac has a Double Extend routine (http://lee-mac.com/doubleextend.html) which you could modify to extend the initial line, offset that and then just draw lines between the 4 end points. If the first 2 lines are just offset from each other then both ends A and ends B will line up?

 

Half a days holiday so not much time to look at your LISP just now but above could work if you are really stuck

 

Try this using my suggestion above - intersections from Lee Mac will work better I reckon though

 

  

(defun XYZchange ( XYZ x y z / nx ny nz )
	(setq 	
		nX (+ x (car  XYZ))
		nY (+ y (cadr XYZ))
		nZ (+ z (caddr XYZ))
	);end setq
	(list nx ny nz)
)

(defun C:fund ( / ent sel dik BRR BR1 startpt endpt MyPline tleft tright Bleft Bright )
;------------------------------------------------------------;
	(setq ent (entsel))
        (setq sel (ssadd (car ent)))
	(setq dik (* -1 (getreal "Thickness: ")))
	(setq BRR (getreal "Extra offset: "))
        (c:dex sel BRR) ;; extend line
	(setq BRl (* -1 BRR))
	(setq MyPline (vlax-ename->vla-object (car ent))
			startpt (vlax-curve-getStartPoint MyPline)
			endpt (vlax-curve-getEndPoint MyPline)
	);end setq

;;------------------------------------------------------------;
	(if (< (car startpt) (car endpt))
		(progn
			(setq tleft startpt)
			(setq tright endpt)
		);end progn
		(progn
			(setq tleft endpt)
			(setq tright startpt)
		);end progn
	);end if
;;------------------------------------------------------------;	
	(setq Bleft (XYZchange tleft 0 dik 0))
	(setq Bright (XYZchange tright 0 dik 0))
	(command "copy" ent "" tleft bleft)
	(setq entb (entlast))


;;------------------------------------------------------------;
        (command "line" (cdr (assoc 10 (entget entb))) (cdr (assoc 10 (entget (car ent)))) "") ;; end line A
        (command "line" (cdr (assoc 11 (entget entb))) (cdr (assoc 11 (entget (car ent)))) "") ;; end line B

;;------------------------------------------------------------;	
;	(setq 
;		toleft	(XYZchange tleft brl 0 0)
;		toright	(XYZchange tright brr 0 0)
;		boleft 	(XYZchange bleft brl 0 0)
;		boright	(XYZchange bright brr 0 0)
;	);end setq
;	(command "line" toleft boleft "")
;	(setq entl (entlast))
;	(command "line" toright boright "")
;	(setq entr (entlast))
;;------------------------------------------------------------;	
;	(command "chamfer" "d" 0 0 tleft bleft)
;	(command "chamfer" "d" 0 0 tright bright)
;	(command "chamfer" "d" 0 0 bleft entl)
;	(command "chamfer" "d" 0 0 bright entr)
)



;;http://lee-mac.com/doubleextend.html
(defun c:dex ( sel ext1 / *error* an1 an2 dis ent enx idx lst pt1 pt2 rad tmp typ )
;;(defun c:dex ( / *error* an1 an2 dis ent enx idx lst pt1 pt2 rad tmp typ ) ;; original line
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

    (LM:startundo (LM:acdoc))
    (if (and (setq tmp (getenv "LMac\\dex"))
             (setq tmp (distof tmp))
             (<  0 tmp)
        )
        (setq ext tmp)
    )
    (initget 6)
    (if
        (and
;            (setq ext
;                (cond
;                    (   (getdist
;                            (strcat "\nSpecify extension"
;                                (if ext (strcat " <" (rtos ext) "> : ") ": ")
;                            )
;                        )
;                    )
;                    (   ext   )
;                )
;            ) ; end setq

(setq ext ext1) ;; added this line

;            (setq sel
;                (LM:ssget "\nSelect lines, arcs and/or polylines to extend: "
;                   '(   "_:L"
;                        (
;                            (-4 . "<OR")
;                                (0 . "LINE,ARC")
;                                (-4 . "<AND")
;                                    (0 . "LWPOLYLINE")
;                                    (-4 . "<NOT")
;                                        (-4 . "&=") (70 . 1)
;                                    (-4 . "NOT>")
;                                (-4 . "AND>")
;                                (-4 . "<AND")
;                                    (0 . "POLYLINE")
;                                    (-4 . "<NOT")
;                                        (-4 . "&=") (70 . 87)
;                                    (-4 . "NOT>")
;                                (-4 . "AND>")
;                            (-4 . "OR>")
;                        )
;                    )
;                )
;            ) ; end setq
        ) ; end and
        (progn
            (setenv "LMac\\dex" (rtos ext))
            (repeat (setq idx (sslength sel))
                (setq ent (ssname sel (setq idx (1- idx)))
                      enx (entget ent)
                      typ (cdr (assoc 0 enx))
                )
                (cond
                    (   (= "LINE" typ)
                        (setq pt1 (cdr (assoc 10 enx))
                              pt2 (cdr (assoc 11 enx))
                              dis (distance pt1 pt2)
                        )
                        (if (not (equal 0.0 dis 1e-8))
                            (progn
                                (setq dis (/ (+ dis ext) dis))
                                (entmod
                                    (subst
                                        (cons  10 (mapcar '+ pt2 (vxs (mapcar '- pt1 pt2) dis)))
                                        (assoc 10 enx)
                                        (subst
                                            (cons  11 (mapcar '+ pt1 (vxs (mapcar '- pt2 pt1) dis)))
                                            (assoc 11 enx)
                                            enx
                                        )
                                    )
                                )
                            )
                        )
                    )
                    (   (= "ARC" typ)
                        (setq rad (cdr (assoc 40 enx))
                              an1 (cdr (assoc 50 enx))
                              an2 (cdr (assoc 51 enx))
                        )
                        (if (< (+ (* rad (rem (+ (- an2 an1) pi pi) (+ pi pi))) ext ext) (* 2.0 rad pi))
                            (entmod
                                (subst
                                    (cons  50 (- an1 (/ ext rad)))
                                    (assoc 50 enx)
                                    (subst
                                        (cons  51 (+ an2 (/ ext rad)))
                                        (assoc 51 enx)
                                        enx
                                    )
                                )
                            )
                        )
                    )
                    (   (= "LWPOLYLINE" typ)
                        (entmod
                            (append
                                (reverse (member (assoc 39 enx) (reverse enx)))
                                (apply 'append (LM:dex:extendpoly (LM:lwvertices enx) ext))
                                (list (assoc 210 enx))
                            )
                        )
                    )
                    (   (= "POLYLINE" typ)
                        (while (/= "SEQEND" (cdr (assoc 0 enx)))
                            (setq ent (entnext ent)
                                  enx (entget  ent)
                                  lst (cons enx lst)
                            )
                        )
                        (foreach vtx (LM:dex:extendpoly (reverse (cdr lst)) ext) (entmod vtx))
                        (entupd (cdr (assoc -2 enx)))
                    )
                )
            )
        )
    )
    (LM:endundo (LM:acdoc))
    (princ)
)

(defun LM:dex:extendpoly ( lst ext / ang bul cen dis len pt1 pt2 pt3 rad )
    (setq pt1 (cdr (assoc 10 (car  lst)))
          pt2 (cdr (assoc 10 (cadr lst)))
          bul (cdr (assoc 42 (car  lst)))
          dis (distance pt1 pt2)
    )
    (if (equal 0.0 bul 1e-8)
        (if (not (equal 0.0 dis 1e-8))
            (setq dis (/ (+ dis ext) dis)
                  lst
                (cons
                    (subst
                        (cons  10 (mapcar '+ pt2 (vxs (mapcar '- pt1 pt2) dis)))
                        (assoc 10 (car lst))
                        (car lst)
                    )
                    (cdr lst)
                )
            )
        )
        (progn
            (setq cen (LM:bulgecentre pt1 pt2 bul)
                  rad (/ (* dis (1+ (* bul bul))) 4 (abs bul))
                  len (abs (* 4 (atan bul) rad))
            )
            (if (< (+ len ext) (* rad 2 pi))
                (setq pt3 (polar cen ((if (minusp bul) + -) (angle cen pt1) (/ ext rad)) rad)
                      ang ((if (minusp bul) - +) (atan bul) (/ ext rad 4.0))
                      lst
                    (cons
                        (subst
                            (cons  10 pt3)
                            (assoc 10 (car lst))
                            (subst
                                (cons  42 (/ (sin ang) (cos ang)))
                                (assoc 42 (car lst))
                                (car lst)
                            )
                        )
                        (cdr lst)
                    )
                )
            )
        )
    )
    (setq lst (reverse lst)
          pt1 (cdr (assoc 10 (car  lst)))
          pt2 (cdr (assoc 10 (cadr lst)))
          bul (cdr (assoc 42 (cadr lst)))
          dis (distance pt1 pt2)
    )
    (if (equal 0.0 bul 1e-8)
        (if (not (equal 0.0 dis 1e-8))
            (setq dis (/ (+ dis ext) dis)
                  lst
                (cons
                    (subst
                        (cons  10 (mapcar '+ pt2 (vxs (mapcar '- pt1 pt2) dis)))
                        (assoc 10 (car lst))
                        (car lst)
                    )
                    (cdr lst)
                )
            )
        )
        (progn
            (setq cen (LM:bulgecentre pt2 pt1 bul)
                  rad (/ (* dis (1+ (* bul bul))) 4 (abs bul))
                  len (abs (* 4 (atan bul) rad))
            )
            (if (< (+ len ext) (* rad 2 pi))
                (setq pt3 (polar cen ((if (minusp bul) - +) (angle cen pt1) (/ ext rad)) rad)
                      ang ((if (minusp bul) - +) (atan bul) (/ ext rad 4.0))
                      lst
                    (vl-list*
                        (subst
                            (cons  10 pt3)
                            (assoc 10 (car lst))
                            (car lst)
                        )
                        (subst
                            (cons  42 (/ (sin ang) (cos ang)))
                            (assoc 42 (cadr lst))
                            (cadr lst)
                        )
                        (cddr lst)
                    )
                )
            )
        )
    )
    (reverse lst)
)

;; Vector x Scalar  -  Lee Mac
;; Args: v - vector in R^n, s - real scalar

(defun vxs ( v s )
    (mapcar '(lambda ( n ) (* n s)) v)
)

;; Bulge Centre  -  Lee Mac
;; p1 - start vertex
;; p2 - end vertex
;; b  - bulge
;; Returns the centre of the arc described by the given bulge and vertices
 
(defun LM:bulgecentre ( p1 p2 b )
    (polar p1
        (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b))))
        (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
    )
)

;; LW Vertices  -  Lee Mac
;; Returns a list of lists in which each sublist describes
;; the position, starting width, ending width and bulge of the
;; vertex of a supplied LWPolyline

(defun LM:lwvertices ( e )
    (if (setq e (member (assoc 10 e) e))
        (cons
            (list
                (assoc 10 e)
                (assoc 40 e)
                (assoc 41 e)
                (assoc 42 e)
            )
            (LM:lwvertices (cdr e))
        )
    )
)

;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)


(vl-load-com)
(princ
    (strcat
        "\n:: DoubleExtend.lsp | Version 1.0 | \\U+00A9 Lee Mac "
        (menucmd "m=$(edtime,0,yyyy)")
        " www.lee-mac.com ::"
        "\n:: Type \"dex\" to Invoke ::"
    )
)

 

Edited by Steven P
  • Thanks 1

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