Topic: Make solid hatch from given plines

[ziele_o2k]

Please see attached dwg.

I have boudary (pline on Layer_1) and internal plines (on Layer_2)
I would like to get list of points to make solid hatch for every area.
For hatch I'm using this function:

Code: [Select]

;; By ElpanovEvgeniy
 ;; 03.04.2007 10:03:51:
(defun entmakex-hatch (L)
 (entmakex
  (apply
   'append
   (list
    (list '(0 . "HATCH")
          '(100 . "AcDbEntity")
          '(410 . "Model")
          '(100 . "AcDbHatch")
          '(10 0.0 0.0 0.0)
          '(210 0.0 0.0 1.0)
          '(2 . "SOLID")
          '(70 . 1)
          '(71 . 0)
          (cons 91 (length l))
    ) ;_  list
    (apply 'append
    (mapcar '(lambda (a)
             (apply 'append
                    (list (list '(92 . 7) '(72 . 0) '(73 . 1) (cons 93 (length a)))
                          (mapcar '(lambda (b) (cons 10 b)) a)
                          '((97 . 0))
                    ) ;_  list
             ) ;_  apply
            ) ;_  lambda
            l
    ) ;_  mapcar
    )
    '((75 . 0)
      (76 . 1)
      (47 . 1.)
      (98 . 2)
      (10 0. 0. 0.0)
      (10 0. 0. 0.0)
      (451 . 0)
      (460 . 0.0)
      (461 . 0.0)
      (452 . 1)
      (462 . 1.0)
      (453 . 2)
      (463 . 0.0)
      (463 . 1.0)
      (470 . "LINEAR")
     )
   ) ;_  list
  ) ;_  apply
 ) ;_  entmakex
); _1)I would like to do that only with ssget plines on layer 1 and layer 2.
2)Second option is to ssget these plines and pick internal point for every area.
Any ideas how to do that?

[ribarm]

Does your polylines have arced segments? If so, then you can't use point list for (entmake) hatch - you have to do it through command "_.HATCH" or "_.BHATCH"... If your polylines have only straight segments, you can get point list with something like this :

(setq L (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget lwpolyline))))
;;; lwpolyline = ename of desired LWPOLYLINE
;;; for ex.
(setq ss (ssget '((0 . "LWPOLYLINE") (8 . "Layer1")))) ;;; <--- you are prompted to select lwpolyline entities that reside on layer "Layer1" no matter if layer is locked or not...
(repeat (setq i (sslength ss))
  (setq lwpolyline (ssname ss (setq i (1- i))))
  (setq L (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget lwpolyline))))
  (entmakex-hatch L)
)

[ziele_o2k]

My plines have only straight segments.
I know also how to get point list of lwpline.
Problem is, how to get list of points to make one hatch for every area?

[ziele_o2k]

In the meantime I found This post,
How to modify bbpoly for my purposes ?

[ribarm]

Evgeniy's code isn't quite appropriate for the task...
Here, try with this - tested on your DWG :

Code: [Select]

;; Batch BPoly  -  Lee Mac
;; Generates polylines for every region formed by a selection of lines & polylines
;; Restricted to LWPolylines with linear segments only.
;; Region generation based on a method by Stefan M.
;; Mod by M.R. to add ability for hatching resulting LWPOLYLINES

;; By ElpanovEvgeniy
;; 03.04.2007 10:03:51:
(defun entmakex-hatch (L)
 (entmakex
  (apply
   'append
   (list
    (list '(0 . "HATCH")
          '(100 . "AcDbEntity")
          '(410 . "Model")
          '(100 . "AcDbHatch")
          '(10 0.0 0.0 0.0)
          '(210 0.0 0.0 1.0)
          '(2 . "SOLID")
          '(70 . 1)
          '(71 . 0)
          '(91 . 1)
    ) ;_  list
    (apply 'append
      (list (list '(92 . 7) '(72 . 0) '(73 . 1) (cons 93 (length L)))
      (mapcar '(lambda (b) (cons 10 b)) L)
      '((97 . 0))
      ) ;_  list
    ) ;_  apply
    '((75 . 0)
      (76 . 1)
      (47 . 1.)
      (98 . 2)
      (10 0. 0. 0.0)
      (10 0. 0. 0.0)
      (451 . 0)
      (460 . 0.0)
      (461 . 0.0)
      (452 . 1)
      (462 . 1.0)
      (453 . 2)
      (463 . 0.0)
      (463 . 1.0)
      (470 . "LINEAR")
     )
   ) ;_  list
  ) ;_  apply
 ) ;_  entmakex
); _

(defun c:bbpoly&hatch ( / *error* big ent enx idx int lst pt1 pt2 rtn sel spc tmp tot val var vtx entl )

    (defun *error* ( msg )
        (foreach obj rtn
            (if (and (vlax-write-enabled-p obj) (not (vlax-erased-p obj)))
                (vla-delete obj)
            )
        )
        (mapcar 'setvar var val)
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

    (LM:startundo (LM:acdoc))
    (cond
        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
            (princ "\nCurrent layer locked.")
        )
        (   (setq sel
                (LM:ssget "\nSelect Lines & Polylines: "
                    (list
                        (list
                           '(-4 . "<OR")
                               '(0 . "LINE")
                               '(-4 . "<AND")
                                   '(0 . "LWPOLYLINE")
                                   '(-4 . "<NOT")
                                       '(-4 . "<>")
                                       '(42 . 0.0)
                                   '(-4 . "NOT>")
                               '(-4 . "AND>")
                           '(-4 . "OR>")
                            (if (= 1 (getvar 'cvport))
                                (cons 410 (getvar 'ctab))
                               '(410 . "Model")
                            )
                        )
                    )
                )
            )
            (setq spc
                (vlax-get-property (LM:acdoc)
                    (if (= 1 (getvar 'cvport))
                        'paperspace
                        'modelspace
                    )
                )
            )
            (repeat (setq idx (sslength sel))
                (if (= "LINE" (cdr (assoc 0 (setq enx (entget (ssname sel (setq idx (1- idx))))))))
                    (setq lst (cons (list (cdr (assoc 10 enx)) (cdr (assoc 11 enx))) lst))
                    (setq vtx (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx))
                          vtx (mapcar 'list vtx (if (= 1 (logand 1 (cdr (assoc 70 enx)))) (cons (last vtx) vtx) (cdr vtx)))
                          lst (append vtx lst)
                    )
                )
            )
            (foreach pl1 lst
                (setq pt1 (car  pl1)
                      pt2 (cadr pl1)
                )
                (foreach pl2 lst
                    (if
                        (and
                            (not (equal pl1 pl2 1e-8))
                            (setq int (inters pt1 pt2 (car pl2) (cadr pl2)))
                            (not (vl-member-if '(lambda ( pnt ) (equal pnt int 1e-8)) pl1))
                        )
                        (setq pl1 (cons int pl1))
                    )
                )
                (setq rtn
                    (append
                        (mapcar
                            (function
                                (lambda ( a b )
                                    (vla-addline spc
                                        (vlax-3D-point a)
                                        (vlax-3D-point b)
                                    )
                                )
                            )
                            (setq pl1
                                (vl-sort pl1
                                    (function
                                        (lambda ( a b )
                                            (< (distance pt1 a) (distance pt1 b))
                                        )
                                    )
                                )
                            )
                            (cdr pl1)
                        )
                        rtn
                    )
                )
            )
            (setq var '(cmdecho peditaccept)
                  val  (mapcar 'getvar var)
                  tot  0.0
            )
            (mapcar 'setvar var '(0 1))
            (foreach reg (vlax-invoke spc 'addregion rtn)
                (setq ent (entlast))
                (command "_.pedit" "_m")
                (apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke reg 'explode)))
                (command "" "_j" "" "")
                (if
                    (and
                        (not (eq ent (setq ent (entlast))))
                        (= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
                    )
                    (progn
                        (setq tmp (vlax-curve-getarea ent)
                              tot (+ tot tmp)
                              entl (cons ent entl)
                        )
                        (if (< (car big) tmp)
                            (setq big (list tmp ent))
                        )
                    )
                )
                (vla-delete reg)
            )
            (if (equal (car big) (/ tot 2.0) 1e-3) ;; Gian Paolo Cattaneo
                (entdel (cadr big))
            )
            (foreach obj rtn (vla-delete obj))
            (mapcar 'setvar var val)
        )
    )
    (foreach ent entl
      (if (not (vlax-erased-p ent))
        (progn
          (entmakex-hatch (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget ent))))
          (entdel ent)
          (command "_.DRAWORDER" "_L" "" "_B")
        )
      )
    )
    (LM:endundo (LM:acdoc))
    (princ)
)

;; 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)

HTH

[ziele_o2k]

Evgeniy's code isn't quite appropriate for the task...

Maybe this:

Code - Auto/Visual Lisp: [Select]

1. (setq hobj (vla-addhatch spc achatchpatterntypepredefined "SOLID" :vlax-true achatchobject))
2.   (vla-appendouterloop hobj
3.     (vlax-make-variant
4.       (vlax-safearray-fill
5.         (vlax-make-safearray vlax-vbobject '(0 . 0))
6.         (list (vlax-ename->vla-object ent))
7.       )
8.     )
9.   )

in place of this

Code - Auto/Visual Lisp: [Select]

1. (entmakex-hatch (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget ent))))

[ribarm]

What I meant to say is that I've modified it slightly... Should be fine if you test my posted code with your DWG... Make sure you select appropriate polylines or make selection with (ssget '((0 . "LWPOLYLINE") (8 . "LAYER1,LAYER2")))... And then when asked for selection while routine, just pass "_Previous"... And that's it, new hatches should be created leaving boundaries unchanged (entdeleted bbpoly polylines)...

[ziele_o2k]

One more thing. Please see attached file.

Plines on layer_2 are with these Lee Mac function
And there is problem with small gaps when I whant to generate solids.
I have no idea where to start... any suggestions?

Function for makeing plines (to run this lisp you have to attached CADPL-Pack library:

Code - Auto/Visual Lisp: [Select]

1. (defun c:tests2p ( / *error* ss in ent lst newent)
2.   (defun *error* (msg / so)
3.     (cond
4.       ((not msg))
5.       ((member msg '("Function cancelled" "quit / exit abort")))
6.       (
7.         (princ (strcat "\n  <!>  Error: " msg "  <!> "))
8.         (cond (DebugMode (vl-bt)))
9.       )
10.     )  
11.     (princ)
12.   )
13.   (cd:SYS_UndoBegin)
14.   (if (setq ss (ssget '((0 . "SPLINE"))))
15.     (repeat (setq in (sslength ss))
16.       (setq
17.         ent (ssname ss (setq in (1- in)))
18.         lst
19.         (mapcar
20.           '(lambda (_1)
21.             (print _1)
22.             (list (car _1) (cadr _1))
23.           )
24.           (LM:Entity->PointList ent)
25.         )
26.       )
27.       (setq newent (vlax-vla-object->ename (cd:ACX_AddLWPolyline (cd:ACX_ASpace) lst nil)))
28.       (cd:ENT_SetDXF newent 8 (cdr (assoc 8 (entget ent))))
29.       (if (cdr (assoc 48 (entget ent)))
30.         (cd:ENT_SetDXF newent 48 (cdr (assoc 48 (entget ent))))
31.       )
32.       (cd:ENT_SetDXF newent 70 128)
33.       (entdel ent)
34.     )
35.   )
36.   (cd:SYS_UndoEnd)
37. )

[ribarm]

You did first step correct - you converted splines to lwpolylines... Then I've found that small gap that had to be connected, then I applied (c:bbpoly&hatch)... It seems that its OK... See DWG in attachment...

BTW. With splined geometry, hatch is I suppose complex to (entmakex), so you'd probably have to use commands, and beside that SPLINES derived from boundaries don't look quite perfect - look around intersecting vertices... See DWG in attachment...

HTH, M.R.

[ziele_o2k]

Then I've found that small gap that had to be connected

My question is, how to connect these plines not manualy but in my lisp tests2p.

[ribarm]

Then I've found that small gap that had to be connected

My question is, how to connect these plines not manualy but in my lisp tests2p.

It's a little complicated, but everything is possible if you want to do it with strong wish... I'd firstly search for intersection points using 'intersectwith method with ending parameter acextendboth... Then I'd compare those points with start/end points of plines... If (vlax-curve-getparamatpoint pline intpoint) ;;; pline - lwpoly ename ;;; intpoint - checking point from 'intersectwith method; returns a value, it means that you don't need to do anything - pline is crossing other pline/entity; but if it returns nil, you have to use "_.EXTEND" command, or even better (entmod) function applied in combination with (subst), so you can change start/end point of pline to match intpoint... That way prepared DWG is ready for next processing like (c:bbpoly&hatch), or if you wish just (c:bbpoly) after which you can manually or again automatically process extrusions on resulting LWPOLYLINES that are closed...

[ribarm]

Not to struggle too much, I've checked my library and I already have something that can help you... First you convert splines to lwpolylines like you know, then you use "plintav-adv.lsp" and then "weld2d.lsp" with fuzz 0.5... The DWG should be prepared for next (c:bbpoly&hatch) or (c:bbpoly)... Now if you want all to be automatic, all you have to do is figure out how to combine those lisps into single one you'll plan to use...

HTH, M.R.

[ziele_o2k]

I came up with something like this

Code - Auto/Visual Lisp: [Select]

1. (defun c:tee4 nil (PZ:FindPlinesToModify (ssget '((0 . "LWPOLYLINE")))))
2. (defun PZ:FindPlinesToModify (ss / EntLst tmpLst)
3.   (setq EntLst (LM:ss->ent ss))
4.   (setq finalLst
5.     (mapcar
6.       '(lambda (_1)
7.         (setq tmpLst
8.           (list _1
9.             (caar
10.               (vl-sort
11.                 (mapcar
12.                   '(lambda (_2)
13.                     (list
14.                       ;_1
15.                       _2
16.                       (distance (vlax-curve-getClosestPointTo (vlax-ename->vla-object _2) (vlax-curve-getStartPoint _1)) (vlax-curve-getStartPoint _1))
17.                     )
18.                   )
19.                   (LM:ListDifference EntLst (list _1))
20.                 )
21.                 (function (lambda (e1 e2) (< (cadr e1) (cadr e2))))
22.               )
23.             )
24.             (caar
25.               (vl-sort
26.                 (mapcar
27.                   '(lambda (_2)
28.                     (list
29.                       ;_1
30.                       _2
31.                       (distance (vlax-curve-getClosestPointTo (vlax-ename->vla-object _2) (vlax-curve-getEndPoint _1)) (vlax-curve-getEndPoint _1))
32.                     )
33.                   )
34.                   (LM:ListDifference EntLst (list _1))
35.                 )
36.                 (function (lambda (e1 e2) (< (cadr e1) (cadr e2))))
37.               )
38.             )
39.           )
40.         )
41.       )
42.       EntLst
43.     )
44.   )
45.   (princl finalLst)
46. )
47. ;; Print List  -  Lee Mac
48. ;; Prints a supplied list to the command-line or to a given filename,
49. ;; with nested lists displayed in a hierarchical format.
50. ;; l - [lst] List to print
51. ;; f - [str] Optional filename
52. (defun LM:princl ( l f / _print _princ d r )
53.    
54.     (defun _print ( l i )
55.         (if (and (= 'list (type l)) (vl-list-length l) (vl-some 'vl-consp l))
56.             (progn
57.                 (_princ (strcat "\n" i "("))
58.                 (foreach x l (_print x (strcat i "    ")))
59.                 (_princ (strcat "\n" i ")"))
60.             )
61.             (_princ (strcat "\n" i (vl-prin1-to-string l)))
62.         )
63.     )
64.  
65.     (eval
66.         (list 'defun '_princ '( x )
67.             (if (and (= 'str (type f)) (setq d (open f "w")))
68.                 (list 'princ 'x d)
69.                '(princ x)
70.             )
71.         )
72.     )
73.  
74.     (setq r (vl-catch-all-apply '_print (list l "")))
75.     (if (= 'file (type d))
76.         (progn
77.             (setq d (close d))
78.             (startapp "notepad" f)
79.         )
80.     )
81.     (if (vl-catch-all-error-p r)
82.         (prompt (vl-catch-all-error-message r))
83.         l
84.     )
85. )
86. (defun princl ( l ) (LM:princl l nil) (princ))
87. (defun princf ( l ) (LM:princl l (vl-filename-mktemp "list" (getvar 'dwgprefix) ".txt")) (princ))
88. (princ)
89. ;;-------------------=={ List Difference }==------------------;;
90. ;;                                                            ;;
91. ;;  Returns items appearing exclusively in one list but not   ;;
92. ;;  another, i.e. the relative complement: l1 \ l2            ;;
93. ;;------------------------------------------------------------;;
94. ;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
95. ;;------------------------------------------------------------;;
96. ;;  Arguments:                                                ;;
97. ;;  l1,l2 - lists for which to return the difference          ;;
98. ;;------------------------------------------------------------;;
99. ;;  Returns:  List of items appearing exclusively in list l1  ;;
100. ;;------------------------------------------------------------;;
101. (defun LM:ListDifference ( l1 l2 )
102.   (vl-remove-if '(lambda ( x ) (member x l2)) l1)
103. )
104. ;;--------------=={ SelectionSet -> Entities }==--------------;;
105. ;;                                                            ;;
106. ;;  Converts a SelectionSet to a list of Entities             ;;
107. ;;------------------------------------------------------------;;
108. ;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
109. ;;------------------------------------------------------------;;
110. ;;  Arguments:                                                ;;
111. ;;  ss - Valid SelectionSet (Pickset)                         ;;
112. ;;------------------------------------------------------------;;
113. ;;  Returns:  List of Entity names, else nil                  ;;
114. ;;------------------------------------------------------------;;
115. (defun LM:ss->ent ( ss / i l )
116.     (if ss
117.         (repeat (setq i (sslength ss))
118.             (setq l (cons (ssname ss (setq i (1- i))) l))
119.         )
120.     )
121. )
122.  

My final list looks like this:

Code: [Select]

(
    (<Nazwa elementu: 7ffff9132c0> <Nazwa elementu: 7ffff913200> <Nazwa elementu: 7ffff9132b0>)
    (<Nazwa elementu: 7ffff9132b0> <Nazwa elementu: 7ffff913200> <Nazwa elementu: 7ffff913200>)
    (<Nazwa elementu: 7ffff9132a0> <Nazwa elementu: 7ffff913200> <Nazwa elementu: 7ffff913290>)
    (<Nazwa elementu: 7ffff913290> <Nazwa elementu: 7ffff913200> <Nazwa elementu: 7ffff913250>)
    (<Nazwa elementu: 7ffff913250> <Nazwa elementu: 7ffff913200> <Nazwa elementu: 7ffff913200>)
    (<Nazwa elementu: 7ffff913200> <Nazwa elementu: 7ffff9132a0> <Nazwa elementu: 7ffff913250>)
)Where first element of sublist is entity of pline to extend, second is entity to which should be extended start point of pline to extend and third element is entity of pline to which should be extended end point of pline to extend.
Now I have to figure out how to do that....
I'm thinking to use something from Lee Mac page, but I have to add some coding for closest intersection of start and end point of polyline to extend.
Intersection with (depend on mode) can return to much intersection points.

[ribarm]

If I may comment your code... I don't quite see how do you plan to use it on your example - gap between start/end point of one pline and closest point of intersection on other pline somewhere on other pline - not start/end vertex... What I stated earlier is logical solution to this task IMHO and 'intersectwith method should be used - well it depends what parameter should you choose acextendthisentity, or acextendotherentity, or alternatively (but I am not 100% sure acextendboth) (acextendnone IMO you should avoid)... I know that my "plintav-adv.lsp" creates additional vertices that may be unnecessary, but you derive lwpolylines from splines anyway and some approximation is therefore applied from the very beginning of process... If I may ask : Do you really need plines? Can you use REGIONS instead? What do you plan to do after when routine is processed? Do you need hatching or extrusions for 3d modelling? Either way it looks that you can avoid all this by simply using BPOLY command with REGION option and then hatch manually or extrude or loft or sweep that region or revolve it or...? Am I right if I may say so that you're loosing time by coding something that could be done faster by manual using commands in command line?

[ziele_o2k]

This is how I want to use this. This coding below has big bugs but this is my direction.

New function is PZ:ExtendPline

Code - Auto/Visual Lisp: [Select]

1. (defun c:tee4 nil (PZ:FindPlinesToModify (ssget '((0 . "LWPOLYLINE")))))
2. (defun PZ:FindPlinesToModify (ss / *error* PZ:ExtendPline EntLst tmpLst)
3.   (defun *error* (msg / so)
4.     (cond
5.       ((not msg))
6.       ((member msg '("Function cancelled" "quit / exit abort")))
7.       (
8.         (princ (strcat "\n  <!>  Error : " msg "  <!> "))
9.         (cond (DebugMode (vl-bt)))
10.       )
11.     )  
12.     (princ)
13.   )
14.   (defun PZ:ExtendPline ( lst / vla_lst pl_m vla_pl_s vla_pl_e tmpLine_s tmpLine_e pts eds pte ede )
15.     (setq
16.       vla_lst (mapcar 'vlax-ename->vla-object lst)
17.       pl_m (car lst)
18.       vla_pl_s (cadr vla_lst)
19.       vla_pl_e (caddr vla_lst)
20.     )
21.     (setq
22.       tmpLine_s
23.       (cd:ACX_AddLine
24.         (cd:ACX_ASpace)
25.         (vlax-curve-getPointAtParam pl_m (vlax-curve-getStartParam pl_m))
26.         (vlax-curve-getPointAtParam pl_m (1+ (vlax-curve-getStartParam pl_m)))
27.         nil
28.       )
29.       tmpLine_e
30.       (cd:ACX_AddLine
31.         (cd:ACX_ASpace)
32.         (vlax-curve-getPointAtParam pl_m (1- (vlax-curve-getEndParam pl_m)))
33.         (vlax-curve-getPointAtParam pl_m (vlax-curve-getEndParam pl_m))
34.         nil
35.       )
36.     )
37.     (cond
38.       (
39.         (setq pts (car(LM:intersections tmpLine_s vla_pl_s acextendnone)))
40.         (setq eds (subst (cons 10 (list (car pts) (cadr pts))) (assoc 10 (entget pl_m)) (entget pl_m)))
41.       )
42.       (
43.         (setq pts (car(LM:intersections tmpLine_s vla_pl_s acextendthisentity)))
44.         (setq eds (subst (cons 10 (list (car pts) (cadr pts))) (assoc 10 (entget pl_m)) (entget pl_m)))
45.       )
46.     )
47.     (entmod eds)
48.     (cond
49.       (
50.         (setq pte (car(LM:intersections tmpLine_e vla_pl_e acextendnone)))
51.         (setq ede (subst (cons 10 (list (car pte) (cadr pte))) (assoc 10 (reverse(entget pl_m))) (entget pl_m)))
52.       )
53.       (
54.         (setq pte (car(LM:intersections tmpLine_e vla_pl_e acextendthisentity)))
55.         (setq ede (subst (cons 10 (list (car pte) (cadr pte))) (assoc 10 (reverse(entget pl_m))) (entget pl_m)))
56.       )
57.     )
58.     (entmod ede)
59.     (vla-Delete tmpLine_s)
60.     (vla-Delete tmpLine_e)
61.   )
62.   (setq EntLst (LM:ss->ent ss))
63.   (setq finalLst
64.     (mapcar
65.       '(lambda (_1)
66.         (setq tmpLst
67.           (list _1
68.             (caar
69.               (vl-sort
70.                 (mapcar
71.                   '(lambda (_2)
72.                     (list
73.                       ;_1
74.                       _2
75.                       (distance (vlax-curve-getClosestPointTo (vlax-ename->vla-object _2) (vlax-curve-getStartPoint _1)) (vlax-curve-getStartPoint _1))
76.                     )
77.                   )
78.                   (LM:ListDifference EntLst (list _1))
79.                 )
80.                 (function (lambda (e1 e2) (< (cadr e1) (cadr e2))))
81.               )
82.             )
83.             (caar
84.               (vl-sort
85.                 (mapcar
86.                   '(lambda (_2)
87.                     (list
88.                       ;_1
89.                       _2
90.                       (distance (vlax-curve-getClosestPointTo (vlax-ename->vla-object _2) (vlax-curve-getEndPoint _1)) (vlax-curve-getEndPoint _1))
91.                     )
92.                   )
93.                   (LM:ListDifference EntLst (list _1))
94.                 )
95.                 (function (lambda (e1 e2) (< (cadr e1) (cadr e2))))
96.               )
97.             )
98.           )
99.         )
100.       )
101.       EntLst
102.     )
103.   )
104.   (foreach _n finalLst (PZ:ExtendPline _n))
105.   (princl finalLst)
106. )
107. ;; Intersections  -  Lee Mac
108. ;; Returns a list of all points of intersection between two objects
109. ;; for the given intersection mode.
110. ;; ob1,ob2 - [vla] VLA-Objects
111. ;;     mod - [int] acextendoption enum of intersectwith method
112.  
113. (defun LM:intersections ( ob1 ob2 mod / lst rtn )
114.     (setq lst (vlax-invoke ob1 'intersectwith ob2 mod))
115.     (repeat (/ (length lst) 3)
116.         (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn)
117.               lst (cdddr lst)
118.         )
119.     )
120.     (reverse rtn)
121. )
122. ;; Print List  -  Lee Mac
123. ;; Prints a supplied list to the command-line or to a given filename,
124. ;; with nested lists displayed in a hierarchical format.
125. ;; l - [lst] List to print
126. ;; f - [str] Optional filename
127. (defun LM:princl ( l f / _print _princ d r )
128.  
129.     (defun _print ( l i )
130.         (if (and (= 'list (type l)) (vl-list-length l) (vl-some 'vl-consp l))
131.             (progn
132.                 (_princ (strcat "\n" i "("))
133.                 (foreach x l (_print x (strcat i "    ")))
134.                 (_princ (strcat "\n" i ")"))
135.             )
136.             (_princ (strcat "\n" i (vl-prin1-to-string l)))
137.         )
138.     )
139.  
140.     (eval
141.         (list 'defun '_princ '( x )
142.             (if (and (= 'str (type f)) (setq d (open f "w")))
143.                 (list 'princ 'x d)
144.                '(princ x)
145.             )
146.         )
147.     )
148.  
149.     (setq r (vl-catch-all-apply '_print (list l "")))
150.     (if (= 'file (type d))
151.         (progn
152.             (setq d (close d))
153.             (startapp "notepad" f)
154.         )
155.     )
156.     (if (vl-catch-all-error-p r)
157.         (prompt (vl-catch-all-error-message r))
158.         l
159.     )
160. )
161. (defun princl ( l ) (LM:princl l nil) (princ))
162. (defun princf ( l ) (LM:princl l (vl-filename-mktemp "list" (getvar 'dwgprefix) ".txt")) (princ))
163. (princ)
164. ;;-------------------=={ List Difference }==------------------;;
165. ;;                                                            ;;
166. ;;  Returns items appearing exclusively in one list but not   ;;
167. ;;  another, i.e. the relative complement: l1 \ l2            ;;
168. ;;------------------------------------------------------------;;
169. ;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
170. ;;------------------------------------------------------------;;
171. ;;  Arguments:                                                ;;
172. ;;  l1,l2 - lists for which to return the difference          ;;
173. ;;------------------------------------------------------------;;
174. ;;  Returns:  List of items appearing exclusively in list l1  ;;
175. ;;------------------------------------------------------------;;
176. (defun LM:ListDifference ( l1 l2 )
177.   (vl-remove-if '(lambda ( x ) (member x l2)) l1)
178. )
179. ;;--------------=={ SelectionSet -> Entities }==--------------;;
180. ;;                                                            ;;
181. ;;  Converts a SelectionSet to a list of Entities             ;;
182. ;;------------------------------------------------------------;;
183. ;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
184. ;;------------------------------------------------------------;;
185. ;;  Arguments:                                                ;;
186. ;;  ss - Valid SelectionSet (Pickset)                         ;;
187. ;;------------------------------------------------------------;;
188. ;;  Returns:  List of Entity names, else nil                  ;;
189. ;;------------------------------------------------------------;;
190. (defun LM:ss->ent ( ss / i l )
191.     (if ss
192.         (repeat (setq i (sslength ss))
193.             (setq l (cons (ssname ss (setq i (1- i))) l))
194.         )
195.     )
196. )