Author Topic: Hatching islands between two polylines  (Read 7900 times)

0 Members and 1 Guest are viewing this topic.

ur_naz

  • Newt
  • Posts: 65
  • Made in Ukraine
Hatching islands between two polylines
« on: September 13, 2013, 11:49:50 AM »
Hello, World! At first sorry for my poor English...
I have two polylines,  which are intersecting each other. The base one is green. Another one is red, generated by my program. So I need to hatch the islands between them in yellow hatch if red pline is above green one and in blue hatch when red pline is below green one.
Is it simple routine to do that? Thanks!

The first image is what i need
The second image is what i have
« Last Edit: September 13, 2013, 12:53:30 PM by ur_naz »

CAB

  • Global Moderator
  • Seagull
  • Posts: 10388
Re: Hatching islands between two polylines
« Reply #1 on: September 13, 2013, 12:08:57 PM »
Welcome.

Have you tried the -.hatch command in a lisp?
I've reached the age where the happy hour is a nap. ()
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

ur_naz

  • Newt
  • Posts: 65
  • Made in Ukraine
Re: Hatching islands between two polylines
« Reply #2 on: September 13, 2013, 12:22:24 PM »
I know this. The problem to me is how to determine internal points of islands to apply hatch command :embarrassed:

LE3

  • Guest
Re: Hatching islands between two polylines
« Reply #3 on: September 13, 2013, 12:35:14 PM »
... I am curios, can you post an image sample with those two plines ---- **the before**

ur_naz

  • Newt
  • Posts: 65
  • Made in Ukraine
Re: Hatching islands between two polylines
« Reply #4 on: September 13, 2013, 12:49:38 PM »
it my fail, but i had uploaded 'hatch.dwg' with my two plines in 1st post.  you can remove all hatch from this file to see *the before* condition  :wink:

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #5 on: September 13, 2013, 12:54:59 PM »
Alanjt has something for getting all intersections between 2 polylines in this thread.

 
Label Contours

LeeMac, has something similar on his pages.

You could apply it to your problem.

ymg

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: Hatching islands between two polylines
« Reply #6 on: September 13, 2013, 01:22:12 PM »
Yes, Lee has intersection functions...

Look here :
http://www.lee-mac.com/intersectionfunctions.html

And if you really want to program this function, I suggest that you recreate each boundary for hatching individually... You just have to reconstruct boundary polyline based on PlPath between 2 adjacent intersection points firstly on red and then on green polyline and join 2 PlPaths... Hatching will be processed alternative above ground then below ground, then again above ground then below ground and so on to the end... Although I strongly think this is better and more reliably doing it manually if you really want routine you'll have to construct it on your own as this programming is time consuming...

For PlPath.lsp look here :
http://www.cadtutor.net/forum/showthread.php?67924-Draw-polyline-along-with-2-or-more-adjacent-closed-polylines/page3&highlight=PlPath&p=#22

This is the way I would approach to this problem, I am not offering only solution, maybe there is more elegant way to accomplish this task... Maybe really internal points for islands, but I think this will lead to unreliably ways...

Just thinking loud...

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ur_naz

  • Newt
  • Posts: 65
  • Made in Ukraine
Re: Hatching islands between two polylines
« Reply #7 on: September 13, 2013, 01:54:05 PM »
Intersections! It must be a good idea! For each pair of intersection points finding pline parameters for both plines, getting middle parameters, getting points at parameter, getting middle point, applying hatch command. I need much more brain to write such code tonight  :-o Thanx you all

GP

  • Newt
  • Posts: 82
  • Vercelli, Italy
Re: Hatching islands between two polylines
« Reply #8 on: September 14, 2013, 07:58:03 AM »
Try, to be completed with the error handling.
 
Code: [Select]
;;; Hatch between two polylines.
;;; Gian Paolo Cattaneo - 14.09.2013
(defun c:TesT ( / cmd e3 e3_ e3p e3p_ npar p_vert ListaV ListaVp LPint contorno_trat)
    (or cal (arxload "geomcal"))
    (vl-load-com)
    (setq cmd (getvar 'cmdecho))
    (setvar 'cmdecho 0)
    (command "_.undo" "_begin")
    (if (and
            (setq e3 (car (entsel "\nSelect First Polyline (GREEN) ")))
            (setq e3_ (vlax-ename->vla-object e3))
            (vl-position (vlax-get e3_ 'ObjectName) '("AcDbPolyline" "AcDb2dPolyline" ))
            (not (redraw e3 3))
            (setq e3p (car (entsel "\nSelect Second Polyline (RED) ")))
            (setq e3p_ (vlax-ename->vla-object e3p))
            (vl-position (vlax-get e3p_ 'ObjectName) '("AcDbPolyline" "AcDb2dPolyline" ))
            (not (redraw e3 4))
            (not (eq e3 e3p))
        )
        (progn
            ;;; poly1
            (repeat (setq n_par (1+ (fix (vlax-curve-getendparam e3))))
                (setq p_vert (vlax-curve-getpointatparam e3 (setq n_par (1- n_par))))
                (setq ListaV (cons p_vert ListaV))
            )
            (if (> (car (car ListaV)) (car (last ListaV))) (setq ListaV (reverse ListaV)))     
            ;;; poly2
            (repeat (setq n_par (1+ (fix (vlax-curve-getendparam e3p))))
                (setq p_vert (vlax-curve-getpointatparam e3p (setq n_par (1- n_par))))
                (setq ListaVp (cons p_vert ListaVp))
            )   
            (if (> (car (car ListaVp)) (car (last ListaVp))) (setq ListaVp (reverse ListaVp)))   
            (lista_punti_intersezione)
            (repeat (1- (length LPint))
                (setq p- (car LPint))
                (setq p+ (cadr LPint))
                (calcolo_contorno_tratteggio)
                (calcolo_tipo_area)
                (disegno_hatch)
                (setq LPint (cdr LPint))
            )
        )
    )
    (prompt "\n ") (prompt "\n ")
    (command "_.undo" "_end")
    (setvar 'cmdecho cmd)
   
    (princ)
)
;;; Returns the intersection points of polylines.
(defun lista_punti_intersezione (/ INT)
    (setq INT (vlax-invoke e3_ 'IntersectWith e3p_ acExtendNone))
    (if INT
 (progn   
     (repeat (/ (length INT) 3)
  (setq LPint (cons (list (car INT)(cadr INT)(caddr INT)) LPint))
         (setq INT (cdddr INT))
     )
            ;Sort the list from left to right
            (setq LPint
           (vl-sort LPint
        (function (lambda (x1 x2) (< (car x1) (car x2))))
            )     )
 )
    )
    (if (< (length LPint) 2)
 (progn
     (alert "The polylines do not intersect in at least two points.")
     (exit)
    )    )   
)
;;; Returns a list of boundary points of the area to be hatched
(defun calcolo_contorno_tratteggio (/ x P_trat_esist P_trat_prog Dp- Dp+ )
    ;First polyline
    (setq Dp- (vlax-curve-getDistAtPoint e3 p-))
    (setq Dp+ (vlax-curve-getDistAtPoint e3 p+))
    (mapcar
        '(lambda (x) (if (and
                             (> (vlax-curve-getDistAtPoint e3 x) 1e-6)       
                             (> (vlax-curve-getDistAtPoint e3 x) Dp-)
                             (< (vlax-curve-getDistAtPoint e3 x) Dp+)
    )   
                  (setq P_trat_esist (cons x P_trat_esist))
  )           )
  ListaV
    )
    (setq P_trat_esist (reverse P_trat_esist)) 
    ;Second polyline
    (setq Dp- (vlax-curve-getDistAtPoint e3p p-))
    (setq Dp+ (vlax-curve-getDistAtPoint e3p p+)) 
    (mapcar
        '(lambda (x) (if (and
                             (> (vlax-curve-getDistAtPoint e3p x) 1e-6)
                             (> (vlax-curve-getDistAtPoint e3p x) Dp-)
                             (< (vlax-curve-getDistAtPoint e3p x) Dp+)
    )   
                  (setq P_trat_prog (cons x P_trat_prog))
  )           )
  ListaVp
    )
    (setq P_trat_prog (reverse P_trat_prog))   
    ;Hatch boundary
    (setq contorno_trat (append (cons p- P_trat_esist) (list p+)))   
    (repeat (setq n (length P_trat_prog))
 (setq contorno_trat (append contorno_trat (list (nth (setq n (1- n)) P_trat_prog))))
    )
)
;;;Return the hatch color
(defun calcolo_tipo_area (/ p_sx apex p_esist p_prog)
    (setq p_sx (list (- (car p-) 1.0) (cadr p-)))
    (setq apex p-)
    (setq p_esist (cadr contorno_trat))
    (setq p_prog (last contorno_trat))
    (if (> (cal "ang (apex, p_sx, p_esist)") (cal "ang (apex, p_sx, p_prog)"))
 (setq col 4) (setq col 2)
    )
   
)
;;;Hatch
(defun disegno_hatch (/ i hatch_def)
    (setq contorno_trat (cons (last contorno_trat) contorno_trat))
    (setq hatch_def (list
   '(0 . "HATCH")
   '(100 . "AcDbEntity")
   '(67 . 0)
   '(410 . "Model")
                        (cons 62 col)
   '(100 . "AcDbHatch")
   '(10 0.0 0.0 0.0)
   '(210 0.0 0.0 1.0)
   '(2 . "SOLID")
   '(70 . 1)
   '(71 . 0)
   '(91 . 1)
   '(92 . 1)
   (cons 93 (1- (length contorno_trat)))
    )               )
    (repeat (setq i (1- (length contorno_trat)))
 (setq hatch_def
                 (append
                     hatch_def
                     (list '(72 . 1))
                     (list (cons 10 (nth i contorno_trat)))
                     (list (cons 11 (nth (setq i (1- i)) contorno_trat)))
                 )
        )
    )
    (setq hatch_def
             (append
                 hatch_def
                 (list '(97 . 0))
                 (list '(75 . 0))
                 (list '(76 . 1))
                 (list '(98 . 1))
                 (list '(10 0.0 0.0 0.0))
                 (list '(470 . "LINEAR"))
             )
    )
    (entmake hatch_def)
    (command "_.draworder" (entlast) "" "_b")
)
 

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #9 on: September 14, 2013, 12:19:05 PM »
Molto buono! Gian Paolo,

In fact the same basic routine could be used to calculates surfaces on a cross section.

ymg

WILL HATCH

  • Bull Frog
  • Posts: 448
Re: Hatching islands between two polylines
« Reply #10 on: September 14, 2013, 08:20:29 PM »
very neat routine,  found a place where it doesn't work properly though

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: Hatching islands between two polylines
« Reply #11 on: September 15, 2013, 02:54:50 AM »
This one is slightly better, but all credits to Gian Paolo Cattaneo...

No need to call (geomcal.arx) - added (ListClockwise-p) subfunction for checking side of boundary polylines and assign correct color... Also added error handler - really simple one, and also make better formatting of code - it's more readable... Also checked for unlocalized variables n_par instead of npar and p- and p+...

Code - Auto/Visual Lisp: [Select]
  1. ;;; Hatch between two polylines.
  2. ;;; Gian Paolo Cattaneo - 14.09.2013
  3. ;;; Marko Ribar modified - 15.09.2013
  4. (defun c:TesT (/        *error*  cmd      e3       e3_      e3p
  5.                e3p_     n_par    p_vert   ListaV   ListaVp  LPint
  6.                contorno_trat     p+       p-       adoc
  7.               )
  8.  
  9.  
  10.   (defun *error* (msg)
  11.     (if adoc
  12.       (vla-endundomark adoc)
  13.     )
  14.     (if cmd
  15.       (setvar 'cmdecho cmd)
  16.     )
  17.     (if msg
  18.       (prompt msg)
  19.     )
  20.     (princ)
  21.   )
  22.  
  23.   (setq cmd (getvar 'cmdecho))
  24.   (setvar 'cmdecho 0)
  25.   (if (and
  26.         (setq e3 (car (entsel "\nSelect First Polyline (GREEN) ")))
  27.         (setq e3_ (vlax-ename->vla-object e3))
  28.         (vl-position
  29.           (vlax-get e3_ 'ObjectName)
  30.           '("AcDbPolyline" "AcDb2dPolyline")
  31.         )
  32.         (not (redraw e3 3))
  33.         (setq e3p (car (entsel "\nSelect Second Polyline (RED) ")))
  34.         (setq e3p_ (vlax-ename->vla-object e3p))
  35.         (vl-position
  36.           (vlax-get e3p_ 'ObjectName)
  37.           '("AcDbPolyline" "AcDb2dPolyline")
  38.         )
  39.         (not (redraw e3 4))
  40.         (not (eq e3 e3p))
  41.       )
  42.     (progn
  43. ;;; poly1
  44.       (repeat (setq n_par (1+ (fix (vlax-curve-getendparam e3))))
  45.         (setq p_vert
  46.                (vlax-curve-getpointatparam e3 (setq n_par (1- n_par)))
  47.         )
  48.         (setq ListaV (cons p_vert ListaV))
  49.       )
  50.       (if (> (car (car ListaV)) (car (last ListaV)))
  51.         (setq ListaV (reverse ListaV))
  52.       )
  53. ;;; poly2
  54.       (repeat (setq n_par (1+ (fix (vlax-curve-getendparam e3p))))
  55.         (setq p_vert (vlax-curve-getpointatparam
  56.                        e3p
  57.                        (setq n_par (1- n_par))
  58.                      )
  59.         )
  60.         (setq ListaVp (cons p_vert ListaVp))
  61.       )
  62.       (if (> (car (car ListaVp)) (car (last ListaVp)))
  63.         (setq ListaVp (reverse ListaVp))
  64.       )
  65.       (lista_punti_intersezione)
  66.       (repeat (1- (length LPint))
  67.         (setq p- (car LPint))
  68.         (setq p+ (cadr LPint))
  69.         (calcolo_contorno_tratteggio)
  70.         (calcolo_tipo_area)
  71.         (disegno_hatch)
  72.         (setq LPint (cdr LPint))
  73.       )
  74.     )
  75.   )
  76.   (prompt "\n ")
  77.   (prompt "\n ")
  78.   (*error* nil)
  79.  
  80.   (princ)
  81. )
  82. ;;; Returns the intersection points of polylines.
  83. (defun lista_punti_intersezione (/ int)
  84.   (setq int (vlax-invoke e3_ 'IntersectWith e3p_ acExtendNone))
  85.   (if int
  86.     (progn
  87.       (repeat (/ (length int) 3)
  88.         (setq
  89.           LPint (cons (list (car int) (cadr int) (caddr int)) LPint)
  90.         )
  91.         (setq int (cdddr int))
  92.       )
  93.                                         ;Sort the list from left to right
  94.       (setq LPint
  95.              (vl-sort LPint
  96.                       (function (lambda (x1 x2) (< (car x1) (car x2))))
  97.              )
  98.       )
  99.     )
  100.   )
  101.   (if (< (length LPint) 2)
  102.     (progn
  103.       (alert
  104.         "The polylines do not intersect in at least two points."
  105.       )
  106.       (exit)
  107.     )
  108.   )
  109. )
  110. ;;; Returns a list of boundary points of the area to be hatched
  111. (defun calcolo_contorno_tratteggio
  112.        (/ x P_trat_esist P_trat_prog Dp- Dp+)
  113.                                         ;First polyline
  114.   (mapcar
  115.     '(lambda (x)
  116.        (if (and
  117.              (> (vlax-curve-getDistAtPoint e3 x) 1e-6)
  118.              (> (vlax-curve-getDistAtPoint e3 x) Dp-)
  119.              (< (vlax-curve-getDistAtPoint e3 x) Dp+)
  120.            )
  121.          (setq P_trat_esist (cons x P_trat_esist))
  122.        )
  123.      )
  124.     ListaV
  125.   )
  126.   (setq P_trat_esist (reverse P_trat_esist))
  127.                                         ;Second polyline
  128.   (mapcar
  129.     '(lambda (x)
  130.        (if (and
  131.              (> (vlax-curve-getDistAtPoint e3p x) 1e-6)
  132.              (> (vlax-curve-getDistAtPoint e3p x) Dp-)
  133.              (< (vlax-curve-getDistAtPoint e3p x) Dp+)
  134.            )
  135.          (setq P_trat_prog (cons x P_trat_prog))
  136.        )
  137.      )
  138.     ListaVp
  139.   )
  140.   (setq P_trat_prog (reverse P_trat_prog))
  141.                                         ;Hatch boundary
  142.   (setq contorno_trat (append (cons p- P_trat_esist) (list p+)))
  143.   (repeat (setq n (length P_trat_prog))
  144.     (setq contorno_trat
  145.            (append contorno_trat
  146.                    (list (nth (setq n (1- n)) P_trat_prog))
  147.            )
  148.     )
  149.   )
  150. )
  151. ;;;ListClockwise-p
  152. (defun ListClockwise-p (lst / z vlst)
  153.   (vl-catch-all-apply
  154.     'minusp
  155.     (list
  156.       (if
  157.         (not
  158.           (equal 0.0
  159.                  (setq z
  160.                         (apply '+
  161.                                (mapcar
  162.                                  (function
  163.                                    (lambda (u v)
  164.                                      (- (* (car u) (cadr v)) (* (car v) (cadr u)))
  165.                                    )
  166.                                  )
  167.                                  (setq vlst
  168.                                         (mapcar
  169.                                           (function
  170.                                             (lambda (a b) (mapcar '- b a))
  171.                                           )
  172.                                           (mapcar (function (lambda (x) (car lst))) lst)
  173.                                           (cdr (reverse (cons (car lst) (reverse lst))))
  174.                                         )
  175.                                  )
  176.                                  (cdr (reverse (cons (car vlst) (reverse vlst))))
  177.                                )
  178.                         )
  179.                  )
  180.                  1e-6
  181.           )
  182.         )
  183.          z
  184.          (progn
  185.            (prompt
  186.              "\n\nChecked vectors are colinear - unable to determine clockwise-p of list"
  187.            )
  188.            nil
  189.          )
  190.       )
  191.     )
  192.   )
  193. )
  194. ;;;Return the hatch color
  195. (defun calcolo_tipo_area nil
  196.   (if (ListClockwise-p contorno_trat)
  197.     (setq col 4)
  198.     (setq col 2)
  199.   )
  200. )
  201. ;;;Hatch
  202. (defun disegno_hatch (/ i hatch_def)
  203.   (setq contorno_trat (cons (last contorno_trat) contorno_trat))
  204.   (setq hatch_def (list
  205.                     '(0 . "HATCH")
  206.                     '(100 . "AcDbEntity")
  207.                     '(67 . 0)
  208.                     '(410 . "Model")
  209.                     (cons 62 col)
  210.                     '(100 . "AcDbHatch")
  211.                     '(10 0.0 0.0 0.0)
  212.                     '(210 0.0 0.0 1.0)
  213.                     '(2 . "SOLID")
  214.                     '(70 . 1)
  215.                     '(71 . 0)
  216.                     '(91 . 1)
  217.                     '(92 . 1)
  218.                     (cons 93 (1- (length contorno_trat)))
  219.                   )
  220.   )
  221.   (repeat (setq i (1- (length contorno_trat)))
  222.     (setq hatch_def
  223.            (append
  224.              hatch_def
  225.              (list '(72 . 1))
  226.              (list (cons 10 (nth i contorno_trat)))
  227.              (list (cons 11 (nth (setq i (1- i)) contorno_trat)))
  228.            )
  229.     )
  230.   )
  231.   (setq hatch_def
  232.          (append
  233.            hatch_def
  234.            (list '(97 . 0))
  235.            (list '(75 . 0))
  236.            (list '(76 . 1))
  237.            (list '(98 . 1))
  238.            (list '(10 0.0 0.0 0.0))
  239.            (list '(470 . "LINEAR"))
  240.          )
  241.   )
  242.   (entmake hatch_def)
  243.   (command "_.draworder" (entlast) "" "_b")
  244. )
  245.  

Invoke with : Command: TesT
« Last Edit: February 17, 2014, 05:31:09 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ur_naz

  • Newt
  • Posts: 65
  • Made in Ukraine
Re: Hatching islands between two polylines
« Reply #12 on: September 15, 2013, 04:28:25 PM »
hello,  guys!  :-) Thank you for reply. Unfortunately my alorithm is not working in acad, however it's works in bricscad perfectly. So I'll try to undersrand on how your examples works.

GP

  • Newt
  • Posts: 82
  • Vercelli, Italy
Re: Hatching islands between two polylines
« Reply #13 on: September 16, 2013, 01:11:46 PM »
Molto buono! Gian Paolo,

Grazie, ymg.  :)
 
 
No need to call (geomcal.arx) - added (ListClockwise-p) subfunction for checking side of boundary polylines and assign correct color... Also added error handler - really simple one, and also make better formatting of code - it's more readable... Also checked for unlocalized variables n_par instead of npar and p- and p+...

Great job, Marko.
 
 
...found a place where it doesn't work properly though

Because the green polyline is drawn from right to left.
 
Updated code:
Code: [Select]
;;; Hatch between two polylines.
;;;
;;; Gian Paolo Cattaneo  - 14.09.2013
;;;
;;; Marko Ribar modified - 15.09.2013
;;;
;;; Gian Paolo Cattaneo  - 16.09.2013
;;; Fixed a bug for polylines drawn from right to left.
;;;
;;;
(defun c:TesT (/        *error*  cmd      e3       e3_      e3p
               e3p_     n_par    p_vert   ListaV   ListaVp  LPint
               contorno_trat     p+       p-       adoc
               inv_p1   inv_p2
              )
    (vl-load-com)
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    (defun *error* (msg)
        (if adoc
            (vla-endundomark adoc)
        )
        (if cmd
            (setvar 'cmdecho cmd)
        )
        (if msg
            (prompt msg)
        )
        (princ)
    )
    (setq cmd (getvar 'cmdecho))
    (setvar 'cmdecho 0)
    (vla-startundomark adoc)
    (if (and
            (setq e3 (car (entsel "\nSelect First Polyline (GREEN) ")))
            (setq e3_ (vlax-ename->vla-object e3))
            (vl-position
                (vlax-get e3_ 'ObjectName)
                '("AcDbPolyline" "AcDb2dPolyline")
            )
            (not (redraw e3 3))
            (setq e3p (car (entsel "\nSelect Second Polyline (RED) ")))
            (setq e3p_ (vlax-ename->vla-object e3p))
            (vl-position
                (vlax-get e3p_ 'ObjectName)
                '("AcDbPolyline" "AcDb2dPolyline")
            )
            (not (redraw e3 4))
            (not (eq e3 e3p))
        )
        (progn
            ;;; poly1
            (repeat (setq n_par (1+ (fix (vlax-curve-getendparam e3))))
                (setq p_vert
                         (vlax-curve-getpointatparam
                             e3
                             (setq n_par (1- n_par))
                         )
                )
                (setq ListaV (cons p_vert ListaV))
            )
            (if (> (car (car ListaV)) (car (last ListaV)))
                (progn
                    (setq ListaV (reverse ListaV))
                    (setq inv_p1 t)
                )
            )
            ;;; poly2
            (repeat
                (setq n_par (1+ (fix (vlax-curve-getendparam e3p))))
                   (setq p_vert (vlax-curve-getpointatparam
                                    e3p
                                    (setq n_par (1- n_par))
                                )
                   )
                   (setq ListaVp (cons p_vert ListaVp))
            )
            (if (> (car (car ListaVp)) (car (last ListaVp)))
                (progn
                    (setq ListaVp (reverse ListaVp))
                    (setq inv_p2 t)
                )
            )
            (lista_punti_intersezione)
            (repeat (1- (length LPint))
                (setq p- (car LPint))
                (setq p+ (cadr LPint))
                (calcolo_contorno_tratteggio)
                (calcolo_tipo_area)
                (disegno_hatch)
                (setq LPint (cdr LPint))
            )
        )
    )
    (prompt "\n ")
    (prompt "\n ")
    (*error* nil)
    (princ)
)
;;; Returns the intersection points of polylines.
(defun lista_punti_intersezione (/ int)
    (setq int (vlax-invoke e3_ 'IntersectWith e3p_ acExtendNone))
    (if int
        (progn
            (repeat (/ (length int) 3)
                (setq
                    LPint
                       (cons (list (car int) (cadr int) (caddr int))
                             LPint
                       )
                )
                (setq int (cdddr int))
            )
            ;Sort the list from left to right
            (setq LPint
                     (vl-sort LPint
                              (function (lambda (x1 x2) (< (car x1) (car x2))))
                     )
            )
        )
    )
    (if (< (length LPint) 2)
        (progn
            (alert
                "The polylines do not intersect in at least two points."
            )
            (exit)
        )
    )
)
;;; Returns a list of boundary points of the area to be hatched
(defun calcolo_contorno_tratteggio (/ x P_trat_esist P_trat_prog Dp- Dp+ L dist )
    ;First polyline
    (setq Dp- (vlax-curve-getDistAtPoint e3 p-))
    (setq Dp+ (vlax-curve-getDistAtPoint e3 p+))   
    (if inv_p1
        (setq
            L (vlax-get-property (vlax-ename->vla-object e3) 'length)
            Dp- (- L Dp-)
            Dp+ (- L Dp+)
        )
    )
    (mapcar
        '(lambda (x)
             (setq dist (vlax-curve-getDistAtPoint e3 x))
             (if inv_p1 (setq dist (- L dist)))
             (if (and                                                               
                     (> dist 1e-6)       
                     (> dist Dp-)
                     (< dist Dp+)                             
                 )   
                 (setq P_trat_esist (cons x P_trat_esist))
      )
         )
  ListaV
    )
    (setq P_trat_esist (reverse P_trat_esist))
    ;Second polyline
    (setq Dp- (vlax-curve-getDistAtPoint e3p p-))
    (setq Dp+ (vlax-curve-getDistAtPoint e3p p+))   
    (if inv_p2
        (setq
            L (vlax-get-property (vlax-ename->vla-object e3p) 'length)
            Dp- (- L Dp-)
            Dp+ (- L Dp+)
        )
    )
    (mapcar
        '(lambda (x)
             (setq dist (vlax-curve-getDistAtPoint e3p x))
             (if inv_p2 (setq dist (- L dist)))           
             (if (and                           
                     (> dist 1e-6)
                     (> dist Dp-)
                     (< dist Dp+)
                 )   
                 (setq P_trat_prog (cons x P_trat_prog))
      )
         )
         ListaVp
    )
    (setq P_trat_prog (reverse P_trat_prog))
    ;Hatch boundary
    (setq contorno_trat (append (cons p- P_trat_esist) (list p+)))   
    (repeat (setq n (length P_trat_prog))
 (setq contorno_trat (append contorno_trat (list (nth (setq n (1- n)) P_trat_prog))))
    )
)
;;;ListClockwise-p
(defun ListClockwise-p (lst / z vlst)
    (vl-catch-all-apply
        'minusp
        (list
            (if
                (not
                    (equal 0.0
                           (setq z
                                    (apply '+
                                           (mapcar
                                               (function
                                                   (lambda (u v)
                                                       (- (* (car u) (cadr v))
                                                          (* (car v) (cadr u))
                                                       )
                                                   )
                                               )
                                               (setq vlst
                                                        (mapcar
                                                            (function
                                                                (lambda (a b)
                                                                    (mapcar '- b a)
                                                                )
                                                            )
                                                            lst
                                                            (cdr (reverse
                                                                     (cons (car lst)
                                                                           (reverse lst)
                                                                     )
                                                                 )
                                                            )
                                                        )
                                               )
                                               (cdr (reverse (cons (car vlst)
                                                                   (reverse vlst)
                                                             )
                                                    )
                                               )
                                           )
                                    )
                           )
                           1e-6
                    )
                )
                   z
                   (progn
                       (prompt
                           "\n\nChecked vectors are colinear - unable to determine clockwise-p of list"
                       )
                       nil
                   )
            )
        )
    )
)
;;;Return the hatch color
(defun calcolo_tipo_area nil
    (if (ListClockwise-p contorno_trat)
        (setq col 4)
        (setq col 2)
    )
)
;;;Hatch
(defun disegno_hatch (/ i hatch_def)
    (setq contorno_trat (cons (last contorno_trat) contorno_trat))
    (setq hatch_def (list
                        '(0 . "HATCH")
                        '(100 . "AcDbEntity")
                        '(67 . 0)
                        '(410 . "Model")
                        (cons 62 col)
                        '(100 . "AcDbHatch")
                        '(10 0.0 0.0 0.0)
                        '(210 0.0 0.0 1.0)
                        '(2 . "SOLID")
                        '(70 . 1)
                        '(71 . 0)
                        '(91 . 1)
                        '(92 . 1)
                        (cons 93 (1- (length contorno_trat)))
                    )
    )
    (repeat (setq i (1- (length contorno_trat)))
        (setq hatch_def
                 (append
                     hatch_def
                     (list '(72 . 1))
                     (list (cons 10 (nth i contorno_trat)))
                     (list (cons 11 (nth (setq i (1- i)) contorno_trat)))
                 )
        )
    )
    (setq hatch_def
             (append
                 hatch_def
                 (list '(97 . 0))
                 (list '(75 . 0))
                 (list '(76 . 1))
                 (list '(98 . 1))
                 (list '(10 0.0 0.0 0.0))
                 (list '(470 . "LINEAR"))
             )
    )
    (entmake hatch_def)
    (command "_.draworder" (entlast) "" "_b")
)

 
 
« Last Edit: September 16, 2013, 01:55:56 PM by GP »

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: Hatching islands between two polylines
« Reply #14 on: February 17, 2014, 05:37:15 AM »
GP, replace this my mistake in your code...

Change this :
Code: [Select]
...
                                               (setq vlst
                                                        (mapcar
                                                            (function
                                                                (lambda (a b)
                                                                    (mapcar '- b a)
                                                                )
                                                            )
                                                            lst
                                                            (cdr (reverse
                                                                     (cons (car lst)
                                                                           (reverse lst)
                                                                     )
                                                                 )
                                                            )
                                                        )
                                               )
...

To this :

Code: [Select]
...
                                               (setq vlst
                                                        (mapcar
                                                            (function
                                                                (lambda (a b)
                                                                    (mapcar '- b a)
                                                                )
                                                            )
                                                            (mapcar
                                                                (function
                                                                    (lambda (x)
                                                                        (car lst)
                                                                    )
                                                                ) lst
                                                            )
                                                            (cdr (reverse
                                                                     (cons (car lst)
                                                                           (reverse lst)
                                                                     )
                                                                 )
                                                            )
                                                        )
                                               )
...

Sorry for late reply and for my mistake...
Sincerely, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

GP

  • Newt
  • Posts: 82
  • Vercelli, Italy
Re: Hatching islands between two polylines
« Reply #15 on: February 17, 2014, 12:37:03 PM »
Thank you, Marko.  :-)

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #16 on: February 18, 2014, 12:49:28 PM »
Here is my interpretation of it.

General flow is I get the list of intersection between the polylines.

Then make sure that the direction of the intersection list is the same
as the reference polyline, otherwise reverse the intersection list.

Then get a midpoint from the distance on both polylines.

The midpoint of this 2 is internal. I use boundary to get the area
then hatch it.

Still have a problem when the polyline are closed.  I need to detect
when the distance goes over the lenght of the poly.

Here is the code:

Code - Auto/Visual Lisp: [Select]
  1. ;;; Cut & Fill      by ymg                                                    ;
  2. ;;;                                                                           ;
  3. ;;; Will return incorrect results if polyline are self-crossing.              ;
  4.  
  5.  
  6.  
  7. (defun c:cf (/ *acaddoc* ar cutcol cw cwi dm1 dm2 dp11 dp12 dp21 dp22 fillcol
  8.                fuzz hatchcol i intl objpol1 objpol2 p p1 p2 pm0 pm1 pm2 pol1
  9.                pol2 ss1 ss2 totcut totfill txt txtlayer valid varl)
  10.      
  11.  
  12.    (defun *error* (msg)
  13.         (mapcar 'eval varl)
  14.         (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
  15.            (princ (strcat "\nError: " msg))
  16.         )
  17.         (and *AcadDoc* (vla-endundomark *AcadDoc*))
  18.         (princ)
  19.    )
  20.      
  21.    (setq varl '("OSMODE" "CMDECHO" "DIMZIN")
  22.          varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) varl)
  23.    )
  24.    
  25.    (or *AcadDoc*
  26.    )
  27.      
  28.    (vla-startundomark *AcadDoc*)
  29.  
  30.    (setvar 'CMDECHO 0)
  31.    (setvar 'DIMZIN  0)
  32.    (setvar 'OSMODE  0)
  33.      
  34.  
  35.   (setq cutcol 1  fillcol 3  ; Cut is Red, Fill is Green                      ;
  36.         totcut 0  totfill 0  ; Total Cut and Total Fill                       ;
  37.           txtlayer "Text"    ; Name of Layer for Cut and Fill Values          ;
  38.          
  39.   )    
  40.   (princ "\nSelect Reference Polyline:")
  41.      (setq ss1 (ssget "_:S"))
  42.      (while  (not (wcmatch (cdr (assoc 0 (entget (ssname ss1 0)))) "*POLYLINE"))
  43.           (princ "\nYou Must Select a Polyline:")
  44.           (setq ss1 (ssget "_:S"))
  45.      )
  46.  
  47.  (princ "\nSelect Proposed Polyline:")
  48.      (setq ss2 (ssget "_:S"))
  49.      (while  (not (wcmatch (cdr (assoc 0 (entget (ssname ss1 0)))) "*POLYLINE"))
  50.           (princ "\nYou Must Select a Polyline:")
  51.           (setq ss2 (ssget "_:S"))
  52.      )
  53.      
  54.  
  55.   (setq pol1 (ssname ss1 0) objpol1 (vlax-ename->vla-object pol1)
  56.         pol2 (ssname ss2 0) objpol2 (vlax-ename->vla-object pol2)
  57.           cw (if (iscw_p (listpol pol1)) 1 -1)
  58.   )
  59.  
  60.  
  61.   ; Getting all the intersections between poly.                               ;
  62.  
  63.   (setq intl (intersections objpol1 objpol2))  
  64.  
  65.  
  66.   ; If polyline is closed add first Intersection to end of list               ;
  67.      
  68.      (setq intl (append intl (list (car intl))))
  69.   )
  70.  
  71.   ; Insure that Intersection List goes same direction as Reference Polyline.  ;
  72.   (setq cwi (if (iscw_p intl) 1 -1))
  73.   (if (/= cw cwi) (setq intl (reverse intl)))
  74.  
  75.   (setq  p1 (car intl)
  76.        dp11 (getdistoncurve pol1 p1)
  77.        dp21 (getdistoncurve pol2 p1)
  78.           i 1
  79.   )
  80.   (repeat (- (length intl) 1)
  81.      (setq valid t           
  82.               p2 (nth i intl)
  83.             dp12 (getdistoncurve pol1 p2)
  84.             dp22 (getdistoncurve pol2 p2)
  85.              dm1 (/ (+ dp11 dp12) 2)                        
  86.              dm2 (/ (+ dp21 dp22) 2)            
  87.              pm1 (getptoncurve pol1 dm1)             
  88.              pm2 (getptoncurve pol2 dm2)
  89.              pm0 (mapcar '/ (mapcar '+ pm1 pm2) '(2. 2.))  ; Internal Point   ;
  90.      )
  91.      (if (> (distance pm1 pm2) 0.00001)
  92.         (progn      
  93.             (vl-cmdf "._-BOUNDARY" pm0 "")
  94.             (setq ar (vla-get-area (vlax-ename->vla-object (entlast))))
  95.             (entdel (entlast))
  96.             (if (minusp (* (onside pm2 p1 pm1) cw))              
  97.                (setq totcut  (+ totcut  ar) hatchcol  cutcol)
  98.                (setq totfill (+ totfill ar) hatchcol fillcol)
  99.             )
  100.             ;(vl-cmdf "._POINT" pm0 "")
  101.             (vl-cmdf "._-HATCH" "_P" "SOLID" "_CO" hatchcol pm0 "")        
  102.         )
  103.      )
  104.      (setq   p1 p2
  105.            dp11 dp12
  106.            dp21 dp22
  107.               i (1+ i)
  108.      )
  109.   )
  110.      
  111.   (if valid
  112.       (progn
  113.           (setq   p (cadr (grread nil 13 0))
  114.                 txt (strcat "{\\C3;Fill: " (rtos totfill 2 2) " m2\\P\\C1;Cut: " (rtos totcut  2 2) " m2}")
  115.           )      
  116.           (entmakex (list
  117.                       (cons 0 "MTEXT")
  118.                       (cons 100 "AcDbEntity")
  119.                       (cons 8 txtlayer)
  120.                       (cons 100 "AcDbMText")
  121.                       (cons 10 p)                
  122.                       (cons 40 3.0)
  123.                       (cons 1 txt)
  124.                     )
  125.           )          
  126.  
  127.           (command "_MOVE" (entlast) "" p pause)
  128.       )
  129.       (Alert "Not Enough Intersections To Process !")
  130.   )
  131.      
  132.   (*error* nil)
  133.      
  134. )
  135.  
  136. (princ "\nCalculates Cut & Fill Between Two Intersecting Polylines")
  137. (princ "\nCF to start...")
  138.  
  139.  
  140.  
  141. ; onside        by ymg                                                        ;
  142. ; Negative return, point is on right of v1->v2                                ;
  143. ; Positive return, point is on left  of v1->v2                                ;
  144. ;        0 return, point is smack on the vector.                              ;
  145. ;                                                                             ;
  146.  
  147. (defun onside (p v1 v2 / x y)
  148.     (setq x (car p) y (cadr p))
  149.     (- (* (- (car  v1) x) (- (cadr v2) y)) (* (- (cadr v1) y) (- (car  v2) x)))    
  150. )
  151.  
  152. ; is the polyline  clockwise.                by LeeMac                        ;
  153. (defun iscw_p (l)    
  154.     (minusp
  155.         (apply '+
  156.             (mapcar
  157.                 (function
  158.                     (lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
  159.                 )
  160.                 l (cons (last l) l)
  161.             )
  162.         )
  163.     )
  164. )
  165.  
  166. ;;****************************************************************************;
  167. ;; Return list of intersection(s) between two objects                         ;
  168. ;; obj1 - first VLA-Object                                                    ;
  169. ;; obj2 - second VLA-Object                                                   ;
  170. ;; mode - intersection mode (acExtendNone acExtendThisEntity                  ;
  171. ;;                                acExtendOtherEntity acExtendBoth)           ;
  172. ;;****************************************************************************;
  173.      
  174. (defun Intersections (obj1 obj2)
  175.    (defun tupl3 (l) (if l (cons (list (car l) (cadr l) (caddr l))(tupl3 (cdddr l)))))
  176.    (tupl3 (vlax-invoke obj1 'intersectwith obj2 acExtendNone))          
  177. )
  178.  
  179.  
  180. (defun getdistoncurve (e p)
  181.              (vlax-curve-getclosestpointto e p)
  182.         )    
  183.    )         
  184. )
  185.  
  186. (defun getptoncurve (e d)
  187. )
  188.  
  189. ;;; listpol   by Gille Chanteau                                               ;
  190. ;;; Returns the vertices list of any type of polyline (WCS coordinates)       ;
  191. ;;;                                                                           ;
  192. ;;; Argument                                                                  ;
  193. ;;; en, a polyline (ename or vla-object)                                      ;
  194.  
  195. (defun listpol (en / i p l)  
  196.   (setq i (vlax-curve-getEndParam en) i (if (vlax-curve-IsClosed en) i (1+ i)))      
  197.       (setq l (cons (trans p 0 1 ) l))
  198.   )
  199. )
  200.  

sanju2323

  • Newt
  • Posts: 65
Re: Hatching islands between two polylines
« Reply #17 on: March 04, 2016, 03:04:00 AM »
Hello sir,
       your Lisp code is very useful for me. But I want to change slightly, to help me if you can. I want it, polyline in the corner of the hatch should arrive. Please see drawing for understanding.

Thank you
sanju

motee-z

  • Newt
  • Posts: 29
Re: Hatching islands between two polylines
« Reply #18 on: March 05, 2016, 12:08:12 PM »
Hello ymg
in some cases your lisp gives this error
Quote
A color number or standard color name is required.
Error: bad argument value: AcDbCurve 71
New background color [Truecolor/COlorbook/. (for none)] <None>: *Cancel*
any suggestion 

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #19 on: March 07, 2016, 05:44:05 AM »
motee-z,

It's a little vague as error description.

Maybe the intersections fails because you have very large coordinates.

If it is the case simply move your curve nearer to 0,0

ymg

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #20 on: March 07, 2016, 06:56:16 AM »
sanju23,

Uses mk-lwp to create a temporary polyline by adding startpoint and endpoint of reference poly to
the proposed poly.

From then on use that temporary poly as your proposed entity.

Code - Auto/Visual Lisp: [Select]
  1. ;;                                                                            ;
  2. ;; mk_lwp    by Alan J Thompson     (Modified by ymg for closed poly)         ;
  3. ;;                                                                            ;
  4. ;; Argument: pl, A list of points (2d or 3d)                                  ;
  5. ;; Create an LWPolyline at Elevation 0, on Current Layer.                     ;
  6. ;; Return: Polyline Object                                                    ;
  7. ;;                                                                            ;
  8.  
  9. (defun mk_lwp (pl / isclosed)
  10.    (setq isclosed 0)
  11.    (if (equal (car pl) (last pl) 0.001)
  12.       (setq isclosed 1 pl (cdr pl))
  13.    )
  14.    (vlax-ename->vla-object
  15.       (entmakex
  16.          (append  (list '(0 . "LWPOLYLINE")
  17.                         '(100 . "AcDbEntity")
  18.                         '(100 . "AcDbPolyline")
  19.                          (cons 90 (length pl))
  20.                          (cons 70 isclosed)
  21.                   )
  22.                   (mapcar '(lambda (p) (cons 10 (trans (list (car p) (cadr p)) 1 0))) pl)
  23.          )
  24.       )
  25.    )
  26. )
  27.  
« Last Edit: March 07, 2016, 07:09:29 AM by ymg »

sanju2323

  • Newt
  • Posts: 65
Re: Hatching islands between two polylines
« Reply #21 on: March 07, 2016, 07:16:07 AM »
ymg,

       This code is very good., Thank you for the help.

sanju

Lee Mac

  • Seagull
  • Posts: 12390
  • London, England
Re: Hatching islands between two polylines
« Reply #22 on: March 07, 2016, 09:53:11 AM »
Code - Auto/Visual Lisp: [Select]
  1. ;;                                                                            ;
  2. ;; mk_lwp    by Alan J Thompson     (Modified by ymg for closed poly)         ;
  3. ;;                                                                            ;
  4. ;; Argument: pl, A list of points (2d or 3d)                                  ;
  5. ;; Create an LWPolyline at Elevation 0, on Current Layer.                     ;
  6. ;; Return: Polyline Object                                                    ;
  7. ;;                                                                            ;
  8.  
  9. (defun mk_lwp (pl / isclosed)
  10.    (setq isclosed 0)
  11.    (if (equal (car pl) (last pl) 0.001)
  12.       (setq isclosed 1 pl (cdr pl))
  13.    )
  14.    (vlax-ename->vla-object
  15.       (entmakex
  16.          (append  (list '(0 . "LWPOLYLINE")
  17.                         '(100 . "AcDbEntity")
  18.                         '(100 . "AcDbPolyline")
  19.                          (cons 90 (length pl))
  20.                          (cons 70 isclosed)
  21.                   )
  22.                   (mapcar '(lambda (p) (cons 10 (trans (list (car p) (cadr p)) 1 0))) pl)
  23.          )
  24.       )
  25.    )
  26. )
  27.  

FWIW, For general purpose, I would suggest the following revision of your function, since LWPolyline vertices are defined relative to the OCS, with elevation determined by DXF group 38:
Code - Auto/Visual Lisp: [Select]
  1. (defun mk_lwp ( lst / cls ocs )
  2.     (if (setq cls (equal (car lst) (last lst) 1e-3))
  3.         (setq lst (cdr lst))
  4.     )
  5.     (setq ocs (trans '(0.0 0.0 1.0) 1 0 t)
  6.           lst (mapcar '(lambda ( x ) (cons 10 (trans x 1 ocs))) lst)
  7.     )
  8.     (entmakex
  9.         (vl-list*
  10.            '(000 . "LWPOLYLINE")
  11.            '(100 . "AcDbEntity")
  12.            '(100 . "AcDbPolyline")
  13.             (cons 090 (length lst))
  14.             (cons 070 (if cls 1 0))
  15.             (cons 038 (car (cdddar lst)))
  16.             (cons 210 ocs)
  17.             lst
  18.         )
  19.     )
  20. )

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #23 on: March 07, 2016, 12:25:55 PM »
Lee,

For general purpose, I agree that your modification are a must.

In my use most of the time I need the poly at elv 0, and like to
have an object returned so I can invoke intersectwith.

The vl-list* is a nice modif.

I believe there is a typo in your code at line 15,
also as submitted will not work for list of 2d point.

Here with typo removed and a little mod for 2d:

Code - Auto/Visual Lisp: [Select]
  1. (defun mk_lwp ( l / cls ocs )
  2.     (if (setq cls (equal (car l) (last l) 1e-3))
  3.        (setq l (cdr l))
  4.     )
  5.     (entmakex
  6.         (vl-list*
  7.            '(000 . "LWPOLYLINE")
  8.            '(100 . "AcDbEntity")
  9.            '(100 . "AcDbPolyline")
  10.             (cons 090 (length lst))
  11.             (cons 070 (if cls 1 0))
  12.             (cons 038 (if (caddar l)(caddar l) 0))
  13.             (cons 210 (setq ocs (trans '(0.0 0.0 1.0) 1 0 t)))
  14.             (mapcar '(lambda (a) (cons 10 (trans a 1 ocs))) l)          
  15.         )
  16.     )
  17. )
  18.  


« Last Edit: March 07, 2016, 01:14:58 PM by ymg »

motee-z

  • Newt
  • Posts: 29
Re: Hatching islands between two polylines
« Reply #24 on: March 07, 2016, 04:40:52 PM »
ymg no large coordinates this case happened when opening new drawing so i have to delete old polylines draw others then may be the lisp work

Lee Mac

  • Seagull
  • Posts: 12390
  • London, England
Re: Hatching islands between two polylines
« Reply #25 on: March 07, 2016, 05:52:57 PM »
I believe there is a typo in your code at line 15,
also as submitted will not work for list of 2d point.

There is no typo as far as I can see; trans will always return a 3D point.

Note that your modifications will cause the function to fail for a UCS whose origin elevation is not equal to that of the WCS origin.
« Last Edit: March 07, 2016, 06:54:02 PM by Lee Mac »

motee-z

  • Newt
  • Posts: 29
Re: Hatching islands between two polylines
« Reply #26 on: March 07, 2016, 07:05:02 PM »
thanks Lee for reply
there is no modification on ymg routin
i know where is the problem now after several tests
if i press enter twice after getting error then repeat the command on other polylines in this case it will work
but if i press escape after getting error the command will not work ever

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: Hatching islands between two polylines
« Reply #27 on: March 07, 2016, 11:10:20 PM »
I believe there is a typo in your code at line 15,
also as submitted will not work for list of 2d point.

There is no typo as far as I can see; trans will always return a 3D point.

Note that your modifications will cause the function to fail for a UCS whose origin elevation is not equal to that of the WCS origin.

I think that you Lee first made mistake with (setq ocs (trans '(0.0 0.0 1.0) 1 0 t))... YMG just copied your version...

Something like this could do it...

Code - Auto/Visual Lisp: [Select]
  1. (defun mk_lwp ( l / v^v unit barycent ocs cls )
  2.  
  3.     (setq l (mapcar '(lambda ( p ) (trans p 1 0)) l))
  4.  
  5.     (defun v^v ( u v )
  6.         (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
  7.         (- (* (caddr u) (car v)) (* (car u) (caddr v)))
  8.         (- (* (car u) (cadr v)) (* (cadr u) (car v)))
  9.     )
  10.  
  11.     (defun unit ( v )
  12.         (if (not (equal v '(0.0 0.0 0.0) 1e-6))
  13.             (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
  14.         )
  15.     )
  16.  
  17.     (defun barycent ( ptlst )
  18.         (mapcar '(lambda ( x ) (/ x (float (length ptlst))))
  19.             (mapcar '(lambda ( x ) (apply '+ x))
  20.                 (apply 'mapcar (cons 'list ptlst))
  21.             )
  22.         )
  23.     )
  24.  
  25.     (cond
  26.         ( (and (caddr l) (setq ocs (unit (v^v (mapcar '- (cadr l) (car l)) (mapcar '- (barycent l) (car l))))))
  27.         )
  28.         ( (and (cadr l) (not (equal (car l) (cadr l) 1e-6)) (setq ocs (unit (v^v '(1.0 0.0 0.0) (unit (mapcar '- (cadr l) (car l)))))))
  29.         )
  30.         ( (or (and (cadr l) (equal (car l) (cadr l) 1e-6)) (not (cadr l)))
  31.           (setq ocs '(0.0 0.0 1.0))
  32.         )
  33.     )
  34.     (if (setq cls (equal (car l) (last l) 1e-3))
  35.         (setq l (cdr l))
  36.     )
  37.     (entmakex
  38.         (vl-list*
  39.            '(000 . "LWPOLYLINE")
  40.            '(100 . "AcDbEntity")
  41.            '(100 . "AcDbPolyline")
  42.             (cons 090 (length lst))
  43.             (cons 070 (if cls (if (eq (getvar 'plinegen) 1) 129 1) (if (eq (getvar 'plinegen) 1) 128 0)))
  44.             (cons 038 (caddr (trans (car l) 0 ocs)))
  45.             (cons 210 ocs)
  46.             (mapcar '(lambda ( p ) (cons 10 (trans p 0 ocs))) l)          
  47.         )
  48.     )
  49. )
  50.  
« Last Edit: March 08, 2016, 02:20:04 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #28 on: March 13, 2016, 08:05:38 AM »
Here a bit better, the closed poly bug is resolved and so is
the problem with not answering the prompt for background color
when calling the hatch command.

Not completely sure that it works in every case, I might have to
rotate the vertices when we got closed polylines.

Code - Auto/Visual Lisp: [Select]
  1. ;;; Cut & Fill      by ymg                                                    ;
  2. ;;;                                                                           ;
  3.  
  4.  
  5.  
  6. (defun c:cf (/ ** *acdoc* a are b bnd c cutcol d dir dl1 dl2 e fillcol hcol
  7.                intl len1 len2 p p0 p1 p2 pm pol1 pol2 sp1 sp2 spe ss1
  8.                ss2 totcut totfill txt txtlayer varl)
  9.                
  10.  
  11.    (defun *error* (msg)
  12.         (mapcar 'eval varl)
  13.         (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
  14.            (princ (strcat "\nError: " msg))
  15.         )
  16.         (and *acdoc* (vla-endundomark *acdoc*))
  17.         (princ)
  18.    )
  19.  
  20.    (setq varl '("OSMODE" "CMDECHO" "DIMZIN" "PEDITACCEPT")
  21.          varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) varl)
  22.    )
  23.  
  24.    (or *acdoc* (setq *acdoc* (vla-get-activedocument (vlax-get-acad-object))))
  25.  
  26.    (vla-startundomark *acdoc*)
  27.  
  28.    (setvar 'CMDECHO 0)
  29.    (setvar 'DIMZIN  0)
  30.    (setvar 'OSMODE  0)
  31.  
  32.  
  33.    (setq cutcol 1  fillcol 3  ; Cut is Red, Fill is Green                     ;
  34.          totcut 0  totfill 0  ; Total Cut and Total Fill                      ;
  35.            txtlayer "Text"    ; Name of Layer for Cut and Fill Values         ;
  36.  
  37.    )
  38.    (while (not (setq **  (princ "\nSelect Reference Polyline:")
  39.                      ss1 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))
  40.                )
  41.           )
  42.         (princ "\nYou Must Select a Polyline:")
  43.    )                  
  44.    (while (not (setq **  (princ "\nSelect Proposed Polyline:")
  45.                      ss2 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))
  46.                )
  47.           )
  48.         (princ "\nYou Must Select a Polyline:")
  49.    )
  50.  
  51.      
  52.    (setq pol1 (ssname ss1 0)
  53.          len1 (vlax-curve-getDistAtParam pol1 (vlax-curve-getEndParam pol1))
  54.          pol2 (ssname ss2 0)
  55.          len2 (vlax-curve-getDistAtParam pol2 (vlax-curve-getEndParam pol2))
  56.          sp1  (vlax-curve-getstartpoint pol1)
  57.          spe  (vlax-curve-getendpoint pol1)
  58.          sp2  (vlax-curve-getstartpoint pol2)
  59.          dir  (direct sp1 spe)
  60.    )      
  61.    
  62.  
  63.    ; Getting all the intersections between poly.                              ;
  64.  
  65.    (setq intl (intersections pol1 pol2))
  66.  
  67.    (if (> (length intl) 1)
  68.       (progn
  69.    
  70.    ; Computing distance of intersections on each polyline                     ;
  71.    
  72.          (setq dl1  (mapcar '(lambda (a) (getdistoncurve pol1 a)) intl)
  73.                dl2  (mapcar '(lambda (a) (getdistoncurve pol2 a)) intl)
  74.          )
  75.    
  76.    ; If both polyline are closed add first Intersection to end of list        ;
  77.    ; We also add a distance to each distances list                            ;
  78.  
  79.          (if (and (vlax-curve-isClosed pol1) (vlax-curve-isClosed pol2))
  80.             (setq dl1  (append dl1 (list (+ (car dl1) len1)))
  81.                   dl2  (append dl2 (list (+ (car dl2) len2)))
  82.                   intl (append intl (list (car intl)))
  83.                   dir  (if (iscw_p (listpol pol1)) -1 1)    
  84.             )      
  85.          )
  86.    
  87.  
  88.    ; Finding points at mid-distance between intersections on each polyline    ;
  89.    ; Calculating midpoint between mid-distance points to get an internal point;
  90.    ; Creating a list of all these points plus the intersection points         ;
  91.    
  92.          (setq pm
  93.             (mapcar
  94.                 '(lambda (a b c d e)
  95.                     (list (midpoint
  96.                               (setq p1 (getptoncurve pol1 (rem (* (+ a b) 0.5) len1)))
  97.                               (setq p2 (getptoncurve pol2 (rem (* (+ c d) 0.5) len2)))
  98.                            )
  99.                            p1 p2 e            
  100.                      )
  101.                   )
  102.                   dl1 (cdr dl1) dl2 (cdr dl2) intl
  103.              )
  104.          )      
  105.  
  106.    
  107.    
  108.          (foreach i pm
  109.             (setq  p (car    i)  ; Midpoint between p1 p2                           ;
  110.                   p0 (cadddr i)  ; Intersection Point                               ;
  111.                   p1 (cadr   i)  ; Midpoint of Intersections on Reference Polyline  ;
  112.                   p2 (caddr  i)  ; Midpoint of Intersections on Proposed Polyline   ;
  113.             )
  114.             (if (> (abs (onside p2 p0 p1)) 1e-3) ; Not Colinear                     ;
  115.                (progn
  116.                   (vl-cmdf "._-BOUNDARY" p "")
  117.                   (setq are (vla-get-area (vlax-ename->vla-object (entlast)))
  118.                         bnd (entlast)
  119.                   )
  120.            
  121.                   (if (minusp (* (onside p2 p0 p1) dir))              
  122.                      (setq totfill (+ totfill are) hcol fillcol)
  123.                      (setq totcut  (+ totcut  are) hcol  cutcol)
  124.                   )
  125.                
  126.                   (vl-cmdf "._-HATCH" "_CO" hcol "." "_P" "SOLID" "_S" bnd "" "")
  127.                   (entdel bnd)
  128.                )
  129.             )
  130.          )
  131.          (setq   p (cadr (grread nil 13 0))
  132.                txt (strcat "{\\C3;Fill: " (rtos totfill 2 2) " m2\\P\\C1;Cut: " (rtos totcut  2 2) " m2}")
  133.          )       
  134.          (entmakex (list
  135.                       (cons 0 "MTEXT")
  136.                       (cons 100 "AcDbEntity")
  137.                       (cons 8 txtlayer)
  138.                       (cons 100 "AcDbMText")
  139.                       (cons 10 p)                
  140.                       (cons 40 3.0)
  141.                       (cons 1 txt)
  142.                     )
  143.          )           
  144.  
  145.          (command "_MOVE" (entlast) "" p pause)
  146.       )
  147.       (Alert "Not Enough Intersections To Process !")
  148.   )
  149.  
  150.   (*error* nil)
  151.  
  152. )
  153.  
  154. (princ "\nCalculates Cut & Fill Between Two Intersecting Polylines")
  155. (princ "\nCF to start...")
  156.  
  157.  
  158. (defun direct (p0 p1)
  159.    (if (< (/ pi 2) (angle p0 p1) (/ (* 3 pi) 2)) -1 1)
  160. )
  161.  
  162. (defun midpoint (p1 p2)
  163.    (mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2)
  164. )
  165.  
  166. ; onside        by ymg                                                        ;
  167. ; Negative return, point is on left of v1->v2                                 ;
  168. ; Positive return, point is on right of v1->v2                                ;
  169. ;        0 return, point is smack on the vector.                              ;
  170. ;                                                                             ;
  171.  
  172. (defun onside (p v1 v2 / x y)
  173.     (setq x (car p) y (cadr p))
  174.     (- (* (- (cadr v1) y) (-  (car v2) x)) (* (- (car  v1) x) (- (cadr v2) y)))
  175. )
  176.  
  177. ;                                                                             ;
  178. ; Is Polyline Clockwise                      by LeeMac                        ;
  179. ;                                                                             ;
  180. ; Argument:   l,  Point List                                                  ;
  181. ; Returns:    t, Polyline is ClockWise                                        ;
  182. ;           nil, Polyline is CounterClockWise                                 ;
  183. ;                                                                             ;
  184.  
  185. (defun iscw_p (l)
  186.     (if (equal (car l) (last l) 1e-8) (setq l (cdr l)))
  187.     (minusp
  188.         (apply '+
  189.             (mapcar
  190.                 (function
  191.                   (lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
  192.                 )
  193.                 l (cons (last l) l)
  194.             )
  195.         )
  196.     )
  197. )
  198.  
  199. ;;                                                                            ;
  200. ;; Return list of intersection(s) between two VLA-Object or two ENAME         ;
  201. ;; obj1 - first VLA-Object                                                    ;
  202. ;; obj2 - second VLA-Object                                                   ;
  203. ;; mode - intersection mode (acExtendNone acExtendThisEntity                  ;
  204. ;;                                acExtendOtherEntity acExtendBoth)           ;
  205. ;; Requires triplet                                                           ;
  206. ;;                                                                            ;
  207.  
  208. (defun Intersections (obj1 obj2)
  209.    (or (= (type obj1) 'VLA-OBJECT) (setq obj1 (vlax-ename->vla-object obj1)))
  210.    (or (= (type obj2) 'VLA-OBJECT) (setq obj2 (vlax-ename->vla-object obj2)))
  211.            
  212.    (triplet (vlax-invoke obj1 'intersectwith obj2 acExtendNone))
  213. )
  214.  
  215. ;;                                                                            ;
  216. ;; triplet, Separates a list into triplets of items.                          ;
  217. ;;                                                                            ;
  218.  
  219. (defun triplet (l)
  220.    (if l (cons (list (car l) (cadr l) (caddr l))(triplet (cdddr l))))
  221. )
  222.  
  223.  
  224. (defun getdistoncurve (e p)
  225.              (vlax-curve-getclosestpointto e p)
  226.         )    
  227.    )         
  228. )
  229.  
  230. (defun getptoncurve (e d)
  231. )
  232.  
  233. ;;                                                                            ;
  234. ;; listpol     by ymg    (Simplified a Routine by Gile Chanteau               ;
  235. ;;                                                                            ;
  236. ;; Parameter:  en,  Entity Name or Object Name of Any Type of Polyline        ;
  237. ;;                                                                            ;
  238. ;; Returns:    List of Points in Current UCS                                  ;
  239. ;;                                                                            ;
  240. ;; Notes:      On Closed Polyline the Last Vertex is Same as First)           ;
  241. ;;                                                                            ;
  242.  
  243. (defun listpol (en / i l)
  244.       (setq l (cons (trans (vlax-curve-getPointAtParam en (setq i (1- i))) 0 1) l))
  245.    )
  246. )
  247.  

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #29 on: March 13, 2016, 11:54:20 AM »
Here I revised to change the origin of the proposed polyline
to the nearest vertex to the reference polyline start point.

Note that it could fail If we have long thin polyline.
Although it is quite unlikely in a tunnel.

Code - Auto/Visual Lisp: [Select]
  1. ;;; Cut & Fill      by ymg                                                    ;
  2. ;;;                                                                           ;
  3.  
  4.  
  5.  
  6. (defun c:cf (/ ** *acdoc* a are b bnd c cutcol d dir dl1 dl2 e fillcol hcol
  7.                intl len1 len2 p p0 p1 p2 pm pol1 pol2 sp1 sp2 spe ss1
  8.                ss2 totcut totfill txt txtlayer varl)
  9.                
  10.  
  11.    (defun *error* (msg)
  12.         (mapcar 'eval varl)
  13.         (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
  14.            (princ (strcat "\nError: " msg))
  15.         )
  16.         (and *acdoc* (vla-endundomark *acdoc*))
  17.         (princ)
  18.    )
  19.  
  20.    (setq varl '("OSMODE" "CMDECHO" "DIMZIN" "PEDITACCEPT")
  21.          varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) varl)
  22.    )
  23.  
  24.    (or *acdoc* (setq *acdoc* (vla-get-activedocument (vlax-get-acad-object))))
  25.  
  26.    (vla-startundomark *acdoc*)
  27.  
  28.    (setvar 'CMDECHO 0)
  29.    (setvar 'DIMZIN  0)
  30.    (setvar 'OSMODE  0)
  31.  
  32.  
  33.    (setq cutcol 1  fillcol 3  ; Cut is Red, Fill is Green                     ;
  34.          totcut 0  totfill 0  ; Total Cut and Total Fill                      ;
  35.            txtlayer "Text"    ; Name of Layer for Cut and Fill Values         ;
  36.  
  37.    )
  38.    (while (not (setq **  (princ "\nSelect Reference Polyline:")
  39.                      ss1 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))
  40.                )
  41.           )
  42.         (princ "\nYou Must Select a Polyline:")
  43.    )                  
  44.    (while (not (setq **  (princ "\nSelect Proposed Polyline:")
  45.                      ss2 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))
  46.                )
  47.           )
  48.         (princ "\nYou Must Select a Polyline:")
  49.    )
  50.  
  51.      
  52.    (setq pol1 (ssname ss1 0)
  53.          len1 (vlax-curve-getDistAtParam pol1 (vlax-curve-getEndParam pol1))
  54.          pol2 (ssname ss2 0)
  55.          len2 (vlax-curve-getDistAtParam pol2 (vlax-curve-getEndParam pol2))
  56.          sp1  (vlax-curve-getstartpoint pol1)
  57.          spe  (vlax-curve-getendpoint pol1)
  58.          sp2  (if (vlax-curve-isClosed pol2)
  59.                  (setq lst2 (listpol pol2)
  60.                        disl (mapcar '(lambda (a) (distance sp1 a)) lst2)
  61.                        **   (plineorg pol2 (nth (vl-position (apply 'min disl) disl) lst2))
  62.                  )
  63.                  (vlax-curve-getstartpoint pol2)
  64.                )  
  65.          dir  (if (< (/ pi 2) (angle sp1 spe) (/ (* 3 pi) 2)) -1 1)
  66.    )      
  67.    
  68.  
  69.    ; Getting all the intersections between poly.                              ;
  70.  
  71.    (setq intl (intersections pol1 pol2))
  72.  
  73.    (if (> (length intl) 1)
  74.       (progn
  75.    
  76.    ; Computing distance of intersections on each polyline                     ;
  77.    
  78.          (setq dl1  (mapcar '(lambda (a) (getdistoncurve pol1 a)) intl)
  79.                dl2  (mapcar '(lambda (a) (getdistoncurve pol2 a)) intl)
  80.          )
  81.    
  82.    ; If both polyline are closed add first Intersection to end of list        ;
  83.    ; We also add a distance to each distances list                            ;
  84.  
  85.          (if (and (vlax-curve-isClosed pol1) (vlax-curve-isClosed pol2))
  86.             (setq dl1  (append dl1 (list (+ (car dl1) len1)))
  87.                   dl2  (append dl2 (list (+ (car dl2) len2)))
  88.                   intl (append intl (list (car intl)))
  89.                   dir  (if (iscw_p (listpol pol1)) -1 1)    
  90.             )      
  91.          )
  92.    
  93.  
  94.    ; Finding points at mid-distance between intersections on each polyline    ;
  95.    ; Calculating midpoint between mid-distance points to get an internal point;
  96.    ; Creating a list of all these points plus the intersection points         ;
  97.    
  98.          (setq pm
  99.             (mapcar
  100.                 '(lambda (a b c d e)
  101.                     (list (midpoint
  102.                               (setq p1 (getptoncurve pol1 (rem (* (+ a b) 0.5) len1)))
  103.                               (setq p2 (getptoncurve pol2 (rem (* (+ c d) 0.5) len2)))
  104.                            )
  105.                            p1 p2 e            
  106.                      )
  107.                   )
  108.                   dl1 (cdr dl1) dl2 (cdr dl2) intl
  109.              )
  110.          )      
  111.  
  112.    
  113.    
  114.          (foreach i pm
  115.             (setq  p (car    i)  ; Midpoint between p1 p2                           ;
  116.                   p0 (cadddr i)  ; Intersection Point                               ;
  117.                   p1 (cadr   i)  ; Midpoint of Intersections on Reference Polyline  ;
  118.                   p2 (caddr  i)  ; Midpoint of Intersections on Proposed Polyline   ;
  119.             )
  120.             (if (> (abs (onside p2 p0 p1)) 1e-3) ; Not Colinear                     ;
  121.                (progn
  122.                   (vl-cmdf "._-BOUNDARY" p "")
  123.                   (setq are (vla-get-area (vlax-ename->vla-object (entlast)))
  124.                         bnd (entlast)
  125.                   )
  126.            
  127.                   (if (minusp (* (onside p2 p0 p1) dir))              
  128.                      (setq totfill (+ totfill are) hcol fillcol)
  129.                      (setq totcut  (+ totcut  are) hcol  cutcol)
  130.                   )
  131.                
  132.                   (vl-cmdf "._-HATCH" "_CO" hcol "." "_P" "SOLID" "_S" bnd "" "")
  133.                   (entdel bnd)
  134.                )
  135.             )
  136.          )
  137.          (setq   p (cadr (grread nil 13 0))
  138.                txt (strcat "{\\C3;Fill: " (rtos totfill 2 2) " m2\\P\\C1;Cut: " (rtos totcut  2 2) " m2}")
  139.          )       
  140.          (entmakex (list
  141.                       (cons 0 "MTEXT")
  142.                       (cons 100 "AcDbEntity")
  143.                       (cons 8 txtlayer)
  144.                       (cons 100 "AcDbMText")
  145.                       (cons 10 p)                
  146.                       (cons 40 3.0)
  147.                       (cons 1 txt)
  148.                     )
  149.          )           
  150.  
  151.          (command "_MOVE" (entlast) "" p pause)
  152.       )
  153.       (Alert "Not Enough Intersections To Process !")
  154.   )
  155.  
  156.   (*error* nil)
  157.  
  158. )
  159.  
  160. (princ "\nCalculates Cut & Fill Between Two Intersecting Polylines")
  161. (princ "\nCF to start...")
  162.  
  163.  
  164.  
  165. (defun midpoint (p1 p2)
  166.    (mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2)
  167. )
  168.  
  169. ; onside        by ymg                                                        ;
  170. ; Negative return, point is on left of v1->v2                                 ;
  171. ; Positive return, point is on right of v1->v2                                ;
  172. ;        0 return, point is smack on the vector.                              ;
  173. ;                                                                             ;
  174.  
  175. (defun onside (p v1 v2 / x y)
  176.     (setq x (car p) y (cadr p))
  177.     (- (* (- (cadr v1) y) (-  (car v2) x)) (* (- (car  v1) x) (- (cadr v2) y)))
  178. )
  179.  
  180. ;                                                                             ;
  181. ; Is Polyline Clockwise                      by LeeMac                        ;
  182. ;                                                                             ;
  183. ; Argument:   l,  Point List                                                  ;
  184. ; Returns:    t, Polyline is ClockWise                                        ;
  185. ;           nil, Polyline is CounterClockWise                                 ;
  186. ;                                                                             ;
  187.  
  188. (defun iscw_p (l)
  189.     (if (equal (car l) (last l) 1e-8) (setq l (cdr l)))
  190.     (minusp
  191.         (apply '+
  192.             (mapcar
  193.                 (function
  194.                   (lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
  195.                 )
  196.                 l (cons (last l) l)
  197.             )
  198.         )
  199.     )
  200. )
  201.  
  202. ;;                                                                            ;
  203. ;; Return list of intersection(s) between two VLA-Object or two ENAME         ;
  204. ;; obj1 - first VLA-Object                                                    ;
  205. ;; obj2 - second VLA-Object                                                   ;
  206. ;; mode - intersection mode (acExtendNone acExtendThisEntity                  ;
  207. ;;                                acExtendOtherEntity acExtendBoth)           ;
  208. ;; Requires triplet                                                           ;
  209. ;;                                                                            ;
  210.  
  211. (defun Intersections (obj1 obj2)
  212.    (or (= (type obj1) 'VLA-OBJECT) (setq obj1 (vlax-ename->vla-object obj1)))
  213.    (or (= (type obj2) 'VLA-OBJECT) (setq obj2 (vlax-ename->vla-object obj2)))
  214.            
  215.    (triplet (vlax-invoke obj1 'intersectwith obj2 acExtendNone))
  216. )
  217.  
  218. ;;                                                                            ;
  219. ;; triplet, Separates a list into triplets of items.                          ;
  220. ;;                                                                            ;
  221.  
  222. (defun triplet (l)
  223.    (if l (cons (list (car l) (cadr l) (caddr l))(triplet (cdddr l))))
  224. )
  225.  
  226.  
  227. (defun getdistoncurve (e p)
  228.              (vlax-curve-getclosestpointto e p)
  229.         )    
  230.    )         
  231. )
  232.  
  233. (defun getptoncurve (e d)
  234. )
  235.  
  236. ;;                                                                            ;
  237. ;; listpol     by ymg    (Simplified a Routine by Gile Chanteau               ;
  238. ;;                                                                            ;
  239. ;; Parameter:  en,  Entity Name or Object Name of Any Type of Polyline        ;
  240. ;;                                                                            ;
  241. ;; Returns:    List of Points in Current UCS                                  ;
  242. ;;                                                                            ;
  243. ;; Notes:      On Closed Polyline the Last Vertex is Same as First)           ;
  244. ;;                                                                            ;
  245.  
  246. (defun listpol (en / i l)
  247.       (setq l (cons (trans (vlax-curve-getPointAtParam en (setq i (1- i))) 0 1) l))
  248.    )
  249. )
  250.  
  251.  
  252. ;; plineorg   by (gile) (Modified into a function by ymg)                     ;
  253. ;;  https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/          ;
  254. ;;            change-polyline-start-point/td-p/2154331                        ;
  255. ;;                                                                            ;
  256. ;; Function to modify origin of a closed polyline                             ;
  257. ;;                                                                            ;
  258. ;; Arguments:                                                                 ;
  259. ;;   en : Ename or VLA-Object of a Closed Polyline.                           ;
  260. ;;   pt : Point                                                               ;
  261. ;;                                                                            ;
  262. ;; Returns: Point of Origin if successful, else nil.                          ;
  263. ;;                                                                            ;
  264.  
  265. (defun plineorg (en pt / blst d1 d2 d3 n norm obj pa plst)
  266.    (if (= (type en) 'ENAME)
  267.       (setq obj (vlax-ename->vla-object  en))
  268.       (setq obj en   en (vlax-vla-object->ename obj))
  269.    )
  270.    
  271.     ;; bulgratio   by (gile)                                 ;
  272.     ;; Returns a bulge which is proportional to a reference  ;
  273.     ;; Arguments :                                           ;
  274.     ;; b : the reference bulge                               ;
  275.     ;; k : the ratio (between angles or arcs length)         ;
  276.  
  277.    (defun bulgratio (b k / a)
  278.       (setq a (atan b))
  279.       (/ (sin (* k a)) (cos (* k a)))
  280.    )
  281.  
  282.     ;; Sublist  by (gile)                                    ;
  283.     ;; Returns a sublist similar to substr function.         ;
  284.     ;; lst : List from which sublist is to be extracted      ;
  285.     ;; idx : Index of Item at Start of sublist               ;
  286.     ;; len : Length of sublist or nil to return all items.   ;
  287.  
  288.    (defun sublist (lst n len / rtn)
  289.       (if (or (not len) (< (- (length lst) n) len))
  290.          (setq len (- (length lst) n))
  291.       )
  292.       (setq n (+ n len))
  293.       (repeat len
  294.          (setq rtn (cons (nth (setq n (1- n)) lst) rtn))
  295.       )
  296.    )
  297.  
  298.    (if (and (= (vla-get-closed obj) :vlax-true)
  299.             (= (vla-get-objectname obj) "AcDbPolyline")
  300.        )    
  301.       (progn
  302.          (setq plst (vlax-get obj 'coordinates)
  303.                norm (vlax-get obj 'normal)
  304.                pt   (vlax-curve-getClosestPointTo en (trans pt 1 0))
  305.                pa   (vlax-curve-getparamatpoint obj pt)
  306.                n    (/ (length plst) 2)        
  307.          )
  308.          (repeat n
  309.             (setq blst (cons (vla-getbulge obj (setq n (1- n))) blst))
  310.          )
  311.          (if (= pa (fix pa))
  312.             (setq n    (fix pa)
  313.                   plst (append (sublist plst (* 2 n) nil)
  314.                                (sublist plst 0 (* 2 n))
  315.                        )
  316.                   blst (append (sublist blst n nil) (sublist blst 0 n))
  317.             )
  318.             (setq n    (1+ (fix pa))
  319.                   d3   (vlax-curve-getdistatparam en n)
  320.                   d2   (- d3 (vlax-curve-getdistatpoint en pt))
  321.                   d3   (- d3 (vlax-curve-getdistatparam en (1- n)))
  322.                   d1   (- d3 d2)
  323.                   pt   (trans pt 0 (vlax-get obj 'normal))
  324.                   plst (append (list (car pt) (cadr pt))
  325.                                (sublist plst (* 2 n) nil)
  326.                                (sublist plst 0 (* 2 n))
  327.                        )
  328.                   blst (append (list (bulgratio (nth (1- n) blst) (/ d2 d3)))
  329.                                (sublist blst n nil)
  330.                                (sublist blst 0 (1- n))
  331.                                (list (bulgratio (nth (1- n) blst) (/ d1 d3)))
  332.                        )
  333.             )
  334.          )
  335.          (vlax-put obj 'coordinates plst)
  336.          (repeat (setq n (length blst))
  337.             (vla-setbulge obj (setq n (1- n)) (nth n blst))
  338.          )
  339.          (trans pt 0 1)
  340.       )
  341.       nil
  342.    )
  343. )
  344.  

motee-z

  • Newt
  • Posts: 29
Re: Hatching islands between two polylines
« Reply #30 on: March 13, 2016, 11:56:00 AM »
thank you ymg for modification but i am sorry to inform you it is not working on my autocad version 2015
and i got these messges
Quote
Select Reference Polyline:
Select objects:
Select Proposed Polyline:
Select objects:
2D point or option keyword required.
2D point or option keyword required.
2D point or option keyword required.
2D point or option keyword required.
2D point or option keyword required.
2D point or option keyword required.
Error: bad argument type: lentityp nil
Specify internal point or [Properties/Select objects/draW boundary/remove Boundaries/Advanced/DRaw order/Origin/ANnotative/hatch COlor/LAyer/Transparency]:
any reason for that

ymg

  • Swamp Rat
  • Posts: 725
Re: Hatching islands between two polylines
« Reply #31 on: March 13, 2016, 12:04:54 PM »
moteez,

I don't have 2015 so I cannot check.

But the most likely reason would be that either the hatch command
or the boundary command have changed the requested input since 2012.

Notes that I do get the message for 2d point but the command completes
normally.

Try changing the hatch line to this:

Code: [Select]
(vl-cmdf "._-HATCH" "_CO" hcol "_P" "SOLID" "_S" bnd "" "")


ymg
« Last Edit: March 13, 2016, 12:18:29 PM by ymg »

motee-z

  • Newt
  • Posts: 29
Re: Hatching islands between two polylines
« Reply #32 on: March 13, 2016, 12:37:40 PM »
perfect gob
Thank you ymg for your efforts

Sudipta2020

  • Mosquito
  • Posts: 2
Re: Hatching islands between two polylines
« Reply #33 on: July 30, 2020, 02:53:10 AM »
you done great work. when this lisp file use in autocad 2018 or higher it create problem of True color.