Jump to content

Offset a Polyline inside or outside


woodman78

Recommended Posts

Hi all,

 

I found this code to offset a polyline inside. It seems to suggest that by changing the sign from - to + it can be switched from inside to outside.

 

I have been at it for hours trying different things but cannot get it to work.

I am trying to integrate this into a bigger lisp that will offset a polyline outisde, then pick a point on that polyline and feed that point with the original polyline into Extrim to cut off everything outside the fence.

 

Can someone help with getting it to offset outside?

Also the code doesn't state anywhere to "Select an object". This is obviously not vanilla lisp. Would it possible to explain where the selected object is within the code?

 

Thanks in advance.

 

;;;Eugeni Elpanov
;;; Arguments
;;;         lw - ename or vla object of polyline
;;; Return
;;;     t - clockwise
;;;    nil - counter-clockwise
(defun lib:pline_clockwise ( lw  / LST MAXP MINP)
(if (= (type lw) 'ENAME)
   (setq lw (vlax-ename->vla-object lw)))  
(vla-GetBoundingBox lw 'MinP 'MaxP)
(setq
minp(vlax-safearray->list minp)
MaxP(vlax-safearray->list MaxP)
lst(mapcar(function(lambda(x)
(vlax-curve-getParamAtPoint lw
(vlax-curve-getClosestPointTo lw x))))
(list minp(list(car minp)(cadr MaxP))
MaxP(list(car MaxP)(cadr minp)))))
(if(or
(<=(car lst)(cadr lst)(caddr lst)(cadddr lst))
(<=(cadr lst)(caddr lst)(cadddr lst)(car lst))
(<=(caddr lst)(cadddr lst)(car lst)(cadr lst))
(<=(cadddr lst)(car lst)(cadr lst)(caddr lst))) t nil))

(defun C:OFF40 ( )
(vl-load-com)
(if  
(and
 (setq en (car(entsel)))
 (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE")
 (or (initget 7) t)
 (setq d (getdist "\nOffset distanse: "))
 (setq en (vlax-ename->vla-object en))
 (vlax-write-enabled-p en)
 (vlax-method-applicable-p en 'Offset)
 (if (lib:pline_clockwise en)
   d
   (setq d (- 0 d))  ;_ Plus or minus To change a sign
   )
 (setq i 1)
 (repeat 40
   (vl-catch-all-apply
     '(lambda()
        (vla-offset en (* i d))
        (setq i (1+ i))
        )
     )
   )
 )
(princ " Offset OK")
(princ "Not a polyline or on locket layer")
)
 (princ)
 )

Link to comment
Share on other sites

  • Replies 25
  • Created
  • Last Reply

Top Posters In This Topic

  • woodman78

    12

  • BKT

    4

  • 1958

    4

  • BIGAL

    3

Top Posters In This Topic

Posted Images

So I got the pline to offset to the outside. Now what I want to do is query the coords of the first vertex on that pline because that will give me a point outside the white closed pline. I can then pass the selection set containing the closed white pline and the coords of vertex 1 on the black pline to Extrim to trim everything outside the inner most pline.

 

How can I query the coords of vertex 1? I just the coords of 1 point on the line.

 

pline.jpg

Link to comment
Share on other sites

I have the code for this all done it's called chevron.lsp I may have posted it here. It uses extrim I am typing waiting for fishing time so will post tomorrow if you can wait.

Link to comment
Share on other sites

Thanks Bigal,

 

That would be great. I am trying to finish my own as well.

I found this snippet of code to get a vertex of a polyline. I have modified it but I cannot get only the first Coord without the Entity Info. Can anyone help please?

 

 (defun c:plpoint ( )
(SETQ LP1 1)
(WHILE LP1
 (PROMPT "\nSelect polyline boundary: ")
 (SETQ PSS (SSGET ":S" '((0 . "LWPOLYLINE"))))
 (IF (/= PSS NIL) (SETQ LP1 NIL) (PROMPT "\nNO POLYLINE SELECTED, TRY AGAIN. "))
);END LP1
(SETQ PEN (SSNAME PSS 0))
(SETQ PENL (ENTGET PEN))
(SETQ PPL (LIST))
(FOREACH N PENL
 (PROGN
  (SETQ PPA (CAR N))
  (SETQ PPV (CDR N))
  (princ PPV)
  ;(IF (= PPA 10) (SETQ PPL (APPEND PPL (LIST PPV))))
));END N
;(SETQ SHSS (SSGET "WP" PPL '((0 . "INSERT") (8 . "L-Irr-Sprayhead"))))
)

 

Here is where I found the code:

http://forums.augi.com/showthread.php?83935-Creating-a-list-Polyline-vertices

 

 

This is the output:

LWPOLYLINE3DC1AcDbEntity0Model0AcDbPolyline310.00.00.0(166.615 343.075)0.00

 

It gives the coord but a whole load of other stuff I don't want. How can I isolate it?

Link to comment
Share on other sites

Thanks 1985 but the output I get is:

 

(166.615 343.075 0.0)(166.615 343.075 0.0)

 

I need ti ioslate it to the coords only.

 

I hope you can understand my english.

Link to comment
Share on other sites

(defun c:plpoint (/)
(vl-load-com)
(setq LP1 1)
(while LP1
 (prompt "\nSelect polyline boundary: ")
 (setq PSS (ssget "_:S" '((0 . "LWPOLYLINE"))))
 (if (/= PSS nil)
  (setq LP1 nil)
  (prompt "\nNO POLYLINE SELECTED, TRY AGAIN. ")
 )
)
(setq PPV (vlax-curve-getStartPoint (vlax-ename->vla-object (ssname PSS 0))))
(vl-princ-to-string PPV)
)

Link to comment
Share on other sites

Thanks 1958

 

If I try to use the coords as below it doesn't work.

 

(defun c:plpoint (/)
(vl-load-com)
(setq LP1 1)
(while LP1
 (prompt "\nSelect polyline boundary: ")
 (setq PSS (ssget "_:S" '((0 . "LWPOLYLINE"))))
 (if (/= PSS nil)
  (setq LP1 nil)
  (prompt "\nNO POLYLINE SELECTED, TRY AGAIN. ")
 )
)
(setq PPV (vlax-curve-getStartPoint (vlax-ename->vla-object (ssname PSS 0))))
(vl-princ-to-string PPV)
[color="red"] (command "_circle" PPV "3")[/color]
)

 

I want to be able to pass the coords to another lisp.

 

Can this be done?

Link to comment
Share on other sites

If you're just looking for the first vertex you could also use:

 

(defun c:test ()

(setq ppv (cdr (assoc 10 (entget (car (entsel "\nSelect Polyline: "))))))

(command "_circle" PPV "3")

(princ ppv)

)

Link to comment
Share on other sites

Woodman78 here is chevron.lsp its close to matching your diagram.

 

; chevron island creater
; this use the extrim command to trim shape
; By Alan H Jan 2012
(defun C:Chevron ( / obj pt1 pt2 pt3 pt4 newpt1 newpt2 )
(acet-error-init (list
                  (list   "cmdecho" 0
                        "highlight" 0
                        "regenmode" 1
                           "osmode" 0
                          "ucsicon" 0
                       "offsetdist" 0
                           "attreq" 0
                         "plinewid" 0
                        "plinetype" 1
                         "gridmode" 0
                          "celtype" "CONTINUOUS"
                        "ucsfollow" 0
                         "limcheck" 0
                  )
                  T     ;flag. True means use undo for error clean up.
                  '(if redraw_it (redraw na 4))
                 );list
);acet-error-init
(setq obj (car (entsel "\nPick pline or circle")))
; should do a object test here
(setq whatis (cdr (assoc 0 (entget obj))))
(if (= whatis "LWPOLYLINE")
(princ)
(progn
(princ "\You have picked something other than a polyline ")
(princ "\Remake into a pline and do again ")
(setq dummy (getstring "\press any key"))
(exit)
) ; progn
) ; if
(setq pt1 (Getpoint "\nPick Line start point"))
(setq pt2 (Getpoint pt1 "\nPick end point"))
(command "line" pt1 pt2 "")
(setq gap1 (getreal "\nenter spacing 1"))
(setq gap2 (getreal "\nenter spacing 2"))
(setq pt3 (getpoint "\nPick 1st cross point"))
(setq pt4 (getpoint pt3 "\nPick 2nd cross point"))
(setq dist (distance pt3 pt4))
(setq x (fix (/ dist (+ gap1 gap2))))
(setq newpt1 (strcat (rtos gap1 2 2) ",0.0"))
(setq newpt2 (strcat (rtos gap2 2 2) ",0.0"))
(repeat x 
(command "copy" "L" "" "0,0" newpt1)
(command "copy" "L" "" "0,0" newpt2)
)
(load "Extrim")
(etrim obj pt1)
(acet-error-restore)
) ; end defun

(princ)

Link to comment
Share on other sites

(defun c:plpoint (/)
(vl-load-com)
(setq LP1 1)
(while LP1
 (prompt "\nSelect polyline boundary: ")
 (setq PSS (ssget "_:S" '((0 . "LWPOLYLINE"))))
 (if (/= PSS nil)
  (setq LP1 nil)
  (prompt "\nNO POLYLINE SELECTED, TRY AGAIN. ")
 )
)
(setq PPV (vlax-curve-getStartPoint (vlax-ename->vla-object (ssname PSS 0))))
(vl-princ-to-string PPV)
(vl-cmdf "_circle" PPV 3)
)

 

Note that to specify the radius of the circle does not need quotation marks.

Link to comment
Share on other sites

Thanks for your help everyone. I appreciate it.

 

Bigal, thank you for the Chevron routine. I was so close with my own I decided to keep going with it.

Link to comment
Share on other sites

So these bits I was looking for help with are part of a larger lisp to create hatch lining road markings. The lisp works by the user selecting a polyline that generally runs up the middle of a closed polyline. This places the hatch markings. By selecting the closed polyline the hatch markings get trimmed.

 

Off40 determines a point outside the polyline in order to pass that to Extrim to trim without having to select a fence and side.

 

The problem I am having is variables related. The lisp works perfectly the first time it is run. It appears to run perfectly the second time with the exception of changing the width of outpline to 0.1.

 

(command "._pedit" outpline "_W" 0.1 "")

 

 

I have run some tests and found out that the variable outpline is not being released after the program completes the first time. It changes the width of the closed polyline from the first run.

 

I know it is an issue with localising variables and I have been through Leemac's tutorial on the subject but when I add it to the variables section of the

 

(defun C:hatch_lining (/ sel1 ang coords elist midp offsetted p1 p2 p3 pline1 SUCE SUOM SUSM SUAB SUAD SUCL SUCR)

 

it causes an error and crashes the program.

 

I would appreciate any help with how to sort the issue.

 

(defun C:hatch_lining (/ sel1 ang coords elist midp offsetted p1 p2 p3 pline1 SUCE SUOM SUSM SUAB SUAD SUCL SUCR)
(setq SUCE (getvar "cmdecho"))
(setq SUOM (getvar "orthomode"))
(setq SUSM (getvar "osmode"))
(setq SUAB (getvar "angbase"))
(setq SUAD (getvar "angdir"))
(setq SUCL (getvar "clayer"))
(setq SUCR (getvar "cecolor"))


(setq vl1 (list
	(cons 0 "LAYER")									;Name of entity
	(cons 100 "AcDbSymbolTableRecord")					;Open Records
	(cons 100 "AcDbLayerTableRecord")					;Locate Layer Table
	(cons 2 "CCC_LAYOUT_Proposed_Road_Lining_Hatching")	;Name of Layer
	(cons 6 "Continuous")								;Linetype
	(cons 62 7)											;colour = light grey
	(cons 70 0)											;state
	(cons 290 1)										;1=plot, 0=Don't plot
		)												;End of entity list
	)
	(entmake vl1)

(command "_.-layer" "_C" "_T" "255,255,255" "CCC_LAYOUT_Proposed_Road_Lining_Hatching" "")
(setvar "clayer" "CCC_LAYOUT_Proposed_Road_Lining_Hatching")  
(setvar "cecolor" "1")
(setq pline1(entsel "\nSelect an arc or a polyline: "))
(setq coords (vl-remove-if (function not)
(mapcar (function (lambda (x)
(if (= 10 (car x))(cdr x))))
elist))
)
(setq p2 (car coords)
midp (mapcar (function (lambda( a b)(/ (+ a b) 2)))
p1 p2)
)

(command "_.insert" "Hatch_Lining" nil)
(command "measure" pline1 "b" "Hatch_Lining" "y" "2.945" "")
(setq SS1 (ssget "X" (list '(0 . "INSERT") (cons 2 "Hatch_Lining"))))
(command "_.draworder" SS1 "" "_F");<--set draw order to front 

(initget "Y N")
(setq option (getkword "\nIs the hatching direction correct: [Y/N]: "))
(cond     ((= option "Y")(hatch_resume))
((= option "N")(hatch_dir_change))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun hatch_dir_change ()
(command "erase" SS1 "" )
(command "_.insert" "Hatch_Lining_90" nil)
(command "measure" pline1 "b" "Hatch_Lining_90" "y" "2.945" "")
(setq SS1 (ssget "X" (list '(0 . "INSERT") (cons 2 "Hatch_Lining_90"))))
(hatch_resume)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun hatch_resume ()
(setvar "qaflags" 1)
(command "explode" SS1 "")
(setvar "qaflags" 0)


(OFF40)


(command "_change" offsetted ""  "p" "Layer" "CCC_LAYOUT_Proposed_Road_Lining_Hatching_Construction" "color" "Bylayer" "")
(setvar "Clayer" "CCC_LAYOUT_Proposed_Road_Lining_Hatching_Construction")

(command "_.-layer" "_OFF" "*" "_N" "")


(extrim)

(setq sel1 (ssget "x" '((8 . "CCC_LAYOUT_Proposed_Road_Lining_Hatching_Construction"))))
(command "layerp")

(command "_change" sel1 ""  "p" "Layer" "CCC_LAYOUT_Proposed_Road_Lining_Hatching" "color" "Bylayer" "")
[color="red"](command "_change" outpline ""  "p" "Layer" "CCC_LAYOUT_Proposed_Road_Lining_Hatching" "color" "Bylayer" "")
(command "._pedit" outpline "_W" 0.1 "")[/color]

(command "_erase" pline1 "" )
(command "_erase" offsetted "" )
(command "_erase" offsettedout "" )


 (setvar "cmdecho"   SUCE)
 (setvar "orthomode" SUOM)
 (setvar "osmode"    SUSM)
 (setvar "angbase"   SUAB)
 (setvar "angdir"    SUAD)
 (setvar "clayer"    SUCL)
 (setvar "cecolor"    SUCR)
(princ) 
)





;;;Eugeni Elpanov
;;; Arguments
;;;         lw - ename or vla object of polyline
;;; Return
;;;     t - clockwise
;;;    nil - counter-clockwise
(defun lib:pline_clockwise ( lw  / LST MAXP MINP)
(if (= (type lw) 'ENAME)
   (setq lw (vlax-ename->vla-object lw)))  
(vla-GetBoundingBox lw 'MinP 'MaxP)
(setq
minp(vlax-safearray->list minp)
MaxP(vlax-safearray->list MaxP)
lst(mapcar(function(lambda(x)
(vlax-curve-getParamAtPoint lw
(vlax-curve-getClosestPointTo lw x))))
(list minp(list(car minp)(cadr MaxP))
MaxP(list(car MaxP)(cadr minp)))))
(if(or
(<=(car lst)(cadr lst)(caddr lst)(cadddr lst))
(<=(cadr lst)(caddr lst)(cadddr lst)(car lst))
(<=(caddr lst)(cadddr lst)(car lst)(cadr lst))
(<=(cadddr lst)(car lst)(cadr lst)(caddr lst))) t nil))

(defun OFF40 ( )
(vl-load-com)
(if  
(and
 (setq en (car(entsel)))
 (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE")
 (or (initget 7) t)
 (setq d 0.3)
 (setq en (vlax-ename->vla-object en))
 (vlax-write-enabled-p en)
 (vlax-method-applicable-p en 'Offset)
 (if (lib:pline_clockwise en)
   d
   (setq d (- 0 d))  ;_ Plus or minus To change a sign
   )
 (setq i 1)
   (vl-catch-all-apply
     '(lambda()
        (vla-offset en (* i d))
        (setq i (1+ i))
        )
     )

	(setq offsetted (entlast)
		elist (entget offsetted)
	)

(setq d 1)	
(if (lib:pline_clockwise en)
   d
   (setq d (- 0 d))  ;_ Plus or minus To change a sign
   )  
(setq i -1)
(vl-catch-all-apply
     '(lambda()
        (vla-offset en (* i d))
        (setq i (1+ i))
        )
     )
	(setq offsettedout (entlast)
		elist (entget offsettedout)
	)

   )


(princ " Offset OK")
(princ "Not a polyline or on locket layer")
)
 (princ)
 )
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
 






;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;;
;;;    EXTRIM.LSP
;;;    Copyright © 1999 by Autodesk, Inc.
;;;
;;;    Your use of this software is governed by the terms and conditions of the
;;;    License Agreement you accepted prior to installation of this software.
;;;    Please note that pursuant to the License Agreement for this software,
;;;    "[c]opying of this computer program or its documentation except as
;;;    permitted by this License is copyright infringement under the laws of
;;;    your country.  If you copy this computer program without permission of
;;;    Autodesk, you are violating the law."
;;;
;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;;    UNINTERRUPTED OR ERROR FREE.
;;;
;;;    Use, duplication, or disclosure by the U.S. Government is subject to
;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer
;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;;    (Rights in Technical Data and Computer Software), as applicable.
;;;
;;;  ----------------------------------------------------------------


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Extended-TRIM - cookie-cutter routine
;
;Select a polyline, line, circle or arc and a side to trim on
;
(defun extrim ( / na e1 p1 redraw_it lst n )

(acet-error-init (list
                  (list   "cmdecho" 0
                        "highlight" 0
                        "regenmode" 1
                           "osmode" 0
                          "ucsicon" 0
                       "offsetdist" 0
                           "attreq" 0
                         "plinewid" 0
                        "plinetype" 1
                         "gridmode" 0
                          "celtype" "CONTINUOUS"
                        "ucsfollow" 0
                         "limcheck" 0
                  )
                  T     ;flag. True means use undo for error clean up.
                  '(if redraw_it (redraw na 4))
                 );list
);acet-error-init


;(princ "\nSelect a closed polyline as TRIM line:...")
;(setq na (acet-ui-single-select '((-4 . "<OR")
;                           (0 . "CIRCLE")
;                           (0 . "ARC")
;                           (0 . "LINE")
;                           (0 . "ELLIPSE")
;                           (0 . "ATTDEF")
;                           (0 . "TEXT")
;                           (0 . "MTEXT")
;                           (0 . "IMAGE")
;                           (0 . "SPLINE")
;                           (0 . "INSERT")
;                           (0 . "SOLID")
;                           (0 . "3DFACE")
;                           (0 . "TRACE")
;                           (0 . "LWPOLYLINE")
;                           (-4 . "<AND")
;                            (0 . "POLYLINE")
;                            (-4 . "<NOT")
;                              (-4 . "&")
;                              (70 . 112)
;                            (-4 . "NOT>")
;                           (-4 . "AND>")
;                          (-4 . "OR>")
;                         )
;                         T
;         );acet-ui-single-select
;setq
(setq na offsetted)
(if na
   (progn
    (setq e1 (entget na));;setq
    (if (or (equal "TEXT"   (cdr (assoc 0 e1)))
            (equal "MTEXT"  (cdr (assoc 0 e1)))
            (equal "ATTDEF" (cdr (assoc 0 e1)))
            (equal "IMAGE"  (cdr (assoc 0 e1)))
            (equal "INSERT" (cdr (assoc 0 e1)))
            (equal "SOLID"  (cdr (assoc 0 e1)))
            (equal "3DFACE" (cdr (assoc 0 e1)))
            (equal "TRACE"  (cdr (assoc 0 e1)))
        );or
        (progn
         (setq lst (acet-geom-object-point-list na nil))
         (setq n 0)
         (command "_.pline")
         (repeat (length lst)
         (command (nth n lst))
         (setq n (+ n 1));setq
         );repeat
         (if (not (equal (car lst) (last lst) 0.0000001))
             (command "_cl")
             (command "")
         );if
         (setq na (entlast)
               e1 na
         );setq
        );progn then draw a temp pline to be the cutting edge.
        (setq e1 nil)
    );if
    (redraw na 3)
    (setq redraw_it T)

    (setq p1 ppv);setq
    (redraw na 4)
    (setq redraw_it nil)
    (if p1 (etrim na p1));if
    (if e1
        (progn
         (if (setq p1 (acet-layer-locked (getvar "clayer")))
             (command "_.layer" "_un" (getvar "clayer") "")
         );if
         (entdel e1)
         (if p1
             (command "_.layer" "_lock" (getvar "clayer") "")
         );if
        );progn then
    );if
   );progn
);if

(acet-error-restore)
(princ)
);defun c:extrim

;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
;Entity-TRIM function
;takes: na - entity name
;  a - a point, the side to trim on
;NOTE: This function does not allow for the possible miss of
;      non-continuous linetypes.
;
(defun etrim ( na a / la b d e1 lst lst2 n j k m ss na2 na3 na4
                     x y z flag flag2 flag3 zlst vpna vplocked
            )


(setq e1 (entget na));setq
(if (or (setq flag (equal (acet-dxf 0 e1) "POLYLINE"))
       (setq flag (equal (acet-dxf 0 e1) "LWPOLYLINE"))
       (equal (acet-dxf 0 e1) "LINE")
       (equal (acet-dxf 0 e1) "CIRCLE")
       (equal (acet-dxf 0 e1) "ARC")
       (equal (acet-dxf 0 e1) "ELLIPSE")
       (equal (acet-dxf 0 e1) "TEXT")
       (equal (acet-dxf 0 e1) "ATTDEF")
       (equal (acet-dxf 0 e1) "MTEXT")
       (equal (acet-dxf 0 e1) "SPLINE")
   );or
   (progn
    (if (and flag
             (equal 8 (logand 8 (acet-dxf 70 e1)))
        );and
        (setq flag nil)
    );if
    (setq     a (trans a 1 0)
           vpna (acet-currentviewport-ename)
    );setq
    (acet-ucs-cmd (list "_View"))

    (setq   lst (acet-geom-object-point-list na nil)  ;;;find extents of selected cutting edge object
            lst (acet-geom-list-extents lst)
              x (- (car (cadr lst)) (car (car lst)))
              y (- (cadr (cadr lst)) (cadr (car lst)))
              x (* 0.075 x)
              y (* 0.075 y)
              z (list x y)
              x (list (+ (car (cadr lst)) (car z))
                      (+ (cadr (cadr lst)) (cadr z))
                );list
              y (list (- (car (car lst)) (car z))
                      (- (cadr (car lst)) (cadr z))
                );list
           zlst (zoom_2_object (list x y))
    );setq
    (if vpna
        (setq vplocked (acet-viewport-lock-set vpna nil)) ;unlock cur viewport if needed.
    );if
    (command "_.zoom" "_w" (car zlst) (cadr zlst))

    (entupd na)                  ;;;update the ent. so it's curves display smoothly

    (setq lst (acet-geom-object-point-list na
                      (/ (acet-geom-pixel-unit) 2.0)
              )
    );setq
    (if (or (not flag)
            (not (acet-geom-self-intersect lst nil))
        );or
        (progn             ;then the object is valid and not a self intersecting polyline.
         (if (and flag
                  (equal (car lst) (last lst) 0.0001)
             );and
             (setq flag3 T);then the polyline could potentialy need a second offset
         );if
         (if (setq la (acet-layer-locked (getvar "clayer")))
             (command "_.layer" "_unl" (getvar "clayer") "")
         );if

         (command "_.pline")
         (setq b nil)
         (setq n 0);setq
         (repeat (length lst)
          (setq d (nth n lst))
          (if (not (equal d b 0.0001))
             (progn
              (command d)
              (setq lst2 (append lst2 (list d)));setq
              (setq b d);setq
             );progn
          );if
          (setq n (+ n 1))
         );repeat
         (command "")
         (setq  na2 (entlast)
                 ss (ssadd)
                 ss (ssadd na2 ss)
                lst nil
         );setq
         (acet-ss-visible ss 1)
         (setq lst2 (get_fence_points na2 a lst2 flag3 flag));setq

         (if la
             (command "_.layer" "_lock" (getvar "clayer") "")
         );if
         (acet-ucs-cmd (list "_p"))
         ;Move the ents to force a display update of the ents to avoid viewres problems.
         (setvar "highlight" 0)
         (if (setq ss (ssget "_f" (last lst2)))
             (command "_.move" ss "" "0,0,0" "0,0,0")
         );if
         (if flag
             (progn
              (if (setq la (acet-layer-locked (acet-dxf 8 e1)))
                  (command "_.layer" "_unl" (acet-dxf 8 e1) "")
              );if
              (acet-ucs-set-z (acet-dxf 210 e1))
              (command "_.copy" na "" "0,0,0" "0,0,0")
              ;(entdel na)
              (acet-ss-visible (ssadd na (ssadd)) 1);make it invisible for a while.
                                                   ;rk 12:01 PM 3/10/98
              (setq na3 na
                     na (entlast)
              );setq
              (command "_.pedit" na "_w" "0.0" "_x")
              (acet-ucs-cmd (list "_p"))
              (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if
             );progn
         );if
         (command "_.trim" na "")
         (setq m (- (length lst2) 1));setq
         (setq k 0)
         (repeat (length lst2)
          (setq lst (nth k lst2))
          (setq a (trans (car lst) 0 1))
          (setq n 1)
          (repeat (- (length lst) 1) ;repeat each fence list
           (setq b (trans (nth n lst) 0 1))
           (if (equal a b 0.0001)
               (setq flag2 T)
               (setq flag2 nil)
           );if
           (setq na4 nil);setq
           (setq j 0);setq
           (while (not flag2)       ;repeat each segment of the fence until no new ents are created.
            (setq na4 (entlast));setq
            (command "_F" a b "")
            (if (and (equal na4 (entlast))
                     (or (not (equal k m))
                         (> j 0)
                     );or
                );and
                (setq flag2 T)
            );if
            (setq j (+ j 1));setq
           );while
           (setq a b);setq
           (setq n (+ n 1));setq
          );repeat

          (setq k (+ k 1))
         );repeat
         (command "")

         (if flag
             (progn
              (if (setq la (acet-layer-locked (acet-dxf 8 e1)))
                  (command "_.layer" "_unl" (acet-dxf 8 e1) "")
              );if
              (entdel na) ;get rid of the copy

              ;(entdel na3);bring back the original
              (acet-ss-visible (ssadd na3 (ssadd)) 0) ;bring back the original
                                                     ;rk 12:01 PM 3/10/98
              (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if
             );progn
         );if
        );progn
        (progn
         (acet-ucs-cmd (list "_p"))
         (princ "\nSelf intersecting edges are not acceptable.")
        );progn else invalid self intersecting polyline
    );if
    (command "_.zoom" "_p")
    (if vplocked
        (acet-viewport-lock-set vpna T) ;then re-lock the viewport
    );if
   );progn then it's a most likely a valid entity.
);if
);defun etrim

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun another_offset ( pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4 / na ss lst da1 da2)

(setq da1 (abs (- a2 a1)));setq
(setq da2 (- (* b (max pl2 pl1))
            (/ (* b (abs (- pl2 pl1)))
                2.0
            )
         )
);setq
(if (> (abs (- da2 da1))
      (* 0.01 (max a1 a2))
   )
   (progn

    (acet-pline-make (list lst2))
    (setq  na (entlast)
          na2 (entlast)
           ss (ssadd)
           ss (ssadd na ss)
    );setq
    (acet-ss-visible ss 1)
    (command "_.offset" b na2 a "")
    (if (and (not (equal na (entlast)))
             (setq lst3 (acet-geom-vertex-list (entlast)))
             (setq lst3 (intersect_check lst2 lst3 lst4))
        );and
        (progn
         (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
         (command "_.area" "_ob" (entlast))
         (setq pl2 (getvar "perimeter")
                a2 (getvar "area")
         );setq
         (setq lst (list (acet-geom-vertex-list (list (entlast) 0))));setq
         (entdel (entlast));then offset was a success so delete the ent after getting it's info
        );progn then
        (if (not (equal na (entlast))) (entdel (entlast)));if else
    );if
    (entdel na2)
   );progn then let's do that second offset
);if

lst
);defun another_offset

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get_fence_points ( na2 a lst2 flag plflag / a1 a2 pl1 pl2 b c d n
                                                  lst lst2 lst3 lst4 na
                       )

(if flag
   (progn
    (setq lst2 (cdr lst2));setq
    (repeat (fix (/ (length lst2) 2))
     (setq lst2 (append (cdr lst2) (list (car lst2)));append
     );setq
    );repeat
    (setq lst2 (append lst2 (list (car lst2))));setq
    (command "_.area" "_ob" na2)
    (setq pl1 (getvar "perimeter")
           a1 (getvar "area")
    );setq
   );progn
);if

(setq    a (trans a 0 1)
        b (* (getvar "viewsize") 0.05);initial offset distance
        n 3.0                         ;number of offsets
        d (/ b (- n 1))               ;delta offset
        c (acet-geom-pixel-unit)
     lst4 (acet-geom-view-points)
);setq

(while (> b c)
(setq na (entlast))
(command "_.offset" b na2 a "")
(if (and (not (equal na (entlast)))
        (setq lst3 (acet-geom-vertex-list (entlast)))
        (or (not plflag)
            (setq lst3 (intersect_check lst2 lst3 lst4))
        );or
   );and
   (progn
    (setq lst3 (acet-geom-m-trans lst3 1 0))
    (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
    (if flag
        (progn
         (command "_.area" "_ob" (entlast))
         (setq pl2 (getvar "perimeter")
                a2 (getvar "area")
         );setq
        );progn
    );if
    (setq lst (append lst (list lst3)));setq
    (entdel (entlast))  ;delete the ent after getting it's vertex info
    (if flag
        (setq lst (append lst
                          (another_offset pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4)
                  );append
        );setq
    );if
   );progn then offset was a success
   (if (not (equal na (entlast))) (entdel (entlast)));if else
);if
(setq b (- b d));setq
);while
(setq na (entlast))
(command "_.offset" c na2 a "")
(if (and (not (equal na (entlast)))
        (setq lst3 (acet-geom-vertex-list (entlast)))
        (or (not plflag)
            (setq lst3 (intersect_check lst2 lst3 lst4))
        );or
   );and
   (progn
    (setq lst3 (acet-geom-m-trans lst3 1 0))
    (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
    (if flag
        (progn
         (command "_.area" "_ob" (entlast))
         (setq pl2 (getvar "perimeter")
                a2 (getvar "area")
         );setq
        );progn
    );if
    (setq lst (append lst (list lst3)));setq
    (entdel (entlast));then offset was a success so delete the ent after getting it's info
    (if flag
        (setq lst (append lst
                          (another_offset pl1 pl2 a1 a2 c na2 lst2 a lst3 lst4)
                  );append
        );setq
    );if
   );progn then
   (if (not (equal na (entlast))) (entdel (entlast)));if else
);if
(entdel na2)

lst
);defun get_fence_points

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;returns a list of points on screen if the first two lists do not
;contain segments that intersect each other.
;
(defun intersect_check ( lst lst2 lst3 / x x2 y y2 lst4 flag len len2
                                        a aa b bb c d n j)

(setq  len (length lst)
     len2 (length lst2)
        x (car (car lst3))
       x2 (car (cadr lst3))
        y (cadr (car lst3))
       y2 (cadr (cadr lst3))
);setq

(setq n 0);setq
(while (and (not flag)
           (< (+ n 1) len2)
      );and
(setq   aa (nth n lst2)
       bb (nth (+ n 1) lst2)
        a (bns_truncate_2_view aa bb x y x2 y2)
        b (bns_truncate_2_view bb aa x y x2 y2)
     lst4 (append lst4 (list a))
);setq
(if (or (not (equal a aa))
       (not (equal b bb))
   );or
   (setq lst4 (append lst4 (list b)))
);if
(setq j 0);setq
(while (and (not flag)
            (< (+ j 1) len)
       );and
(setq    c (nth j lst)
         d (nth (+ j 1) lst)
      flag (inters a b c d)
);setq

(setq j (+ j 1));setq
);while

(setq n (+ n 1));setq
);while
(if (not (equal b (last lst4)))
   (setq lst4 (append lst4 (list b)));setq
);if
(if (not flag)
   (setq flag lst4)
   (setq flag nil)
);if
flag
);defun intersect_check

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun zoom_2_object ( lst / p1 p2 p3 p4 p5 p6 mp dx dy dx2 dy2
                            r1 r2 na e1 x w h dv1 dv2 x
                    )

(setq  lst (acet-geom-m-trans lst 1 2)
        p1 (acet-geom-m-trans (acet-geom-view-points) 1 2)    ;p1 and p2 are the viewpnts
        p2 (cadr p1)
        p1 (car p1)
        p1 (list (car p1) (cadr p1))
        p2 (list (car p2) (cadr p2))
);setq
(if lst
    (progn
     (setq   p5 (acet-geom-list-extents lst)              ;p5 and p6 are the geometry points
             p6 (cadr p5)
             p5 (car p5)
             p5 (list (car p5) (cadr p5))
             p6 (list (car p6) (cadr p6))
             mp (acet-geom-midpoint p5 p6)           ;prepare to resize the geometry rectang to
             dx (- (car p2) (car p1))    ;have the same dy/dx ratio as p1 p2.
             dy (- (cadr p2) (cadr p1))
            dx2 (- (car p6) (car p5))
            dy2 (- (cadr p6) (cadr p5))
     );setq
     (if (equal dx 0.0)  (setq dx 0.000001))  ;just in case div by zero
     (if (equal dx2 0.0) (setq dx2 0.000001))
     (setq   r1 (/ dy dx)
             r2 (/ dy2 dx2)
     );setq
     (if (< r2 r1)
         (setq dy2 (* r1 dx2));then scale dy2 up
         (progn
          (if (equal r1 0.0)  (setq r1 0.000001))  ;just in case div by zero
          (setq dx2 (* dy2 (/ 1.0 r1)));else scale dx2 up
         );progn
     );if
     (setq p5 (list (- (car mp) (/ dx2 1.98))   ;1.98 is used instead of 2.0 to expand
                    (- (cadr mp) (/ dy2 1.98))  ;the rectangle slightly
              );list
           p6 (list (+ (car mp) (/ dx2 1.98))
                    (+ (cadr mp) (/ dy2 1.98))
              );list
     );setq
    );progn then lst
);if
(if (and lst
         (equal 0 (getvar "tilemode"))
         (not (equal 1 (getvar "cvport")))
         (setq na (acet-currentviewport-ename))
    );and
    (progn
     (setq  e1 (entget na)
             x (cdr (assoc 10 e1))
             w (cdr (assoc 40 e1))
             h (cdr (assoc 41 e1))
            p3 (list (- (car x) (/ w 2.0))
                     (- (cadr x) (/ h 2.0))
               );list
            p4 (list (+ (car x) (/ w 2.0))
                     (+ (cadr x) (/ h 2.0))
               );list
            p3 (trans p3 3 2)      ;p3 and p4 are the viewport points
            p4 (trans p4 3 2)
           dv1 (acet-geom-delta-vector p1 p3)
           dv2 (acet-geom-delta-vector p2 p4)
             x (distance p1 p2)
     );setq
     (if (equal 0 x) (setq x 0.000001));just in case
     (setq   x (/ (distance p5 p6)
                  x
               )
           dv1 (acet-geom-vector-scale dv1 x)
           dv2 (acet-geom-vector-scale dv2 x)
            p5 (acet-geom-vector-add p5 dv1)
            p6 (acet-geom-vector-add p6 dv2)
      );setq
    );progn then
);if
(setq p1 (list (car p1) (cadr p1) 0.0)
      p2 (list (car p2) (cadr p2) 0.0)
      p5 (list (car p5) (cadr p5) 0.0)
      p6 (list (car p6) (cadr p6) 0.0)
);setq
(if lst
    (setq lst (list (trans p5 2 1)
                    (trans p6 2 1)
              );list
    );setq
    (setq lst nil)
);if

lst
);defun zoom_2_object


(princ)

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.


×
×
  • Create New...