Author Topic: Hatching islands between two polylines ( ymg LISP CODE)  (Read 575 times)

0 Members and 1 Guest are viewing this topic.

pedroantonio

  • Guest
Hatching islands between two polylines ( ymg LISP CODE)
« on: September 20, 2017, 04:04:29 AM »
Hi ymg. I am using an old code for Fill and Cut Areas. Is  it possible to move the hach area in a layer. I am using Autocad 2017. I try to use the new ver 2.0 from here https://www.theswamp.org/index.php?topic=45305.15 but when i select the polylines them delete them and insert the fill/cut text

here is the code i use. This code  is working for me but is not create a Hatch layer for the haches.

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

Any idea

Thanks

ribarm

  • Water Moccasin
  • Posts: 2366
  • Marko Ribar, architect
Re: Hatching islands between two polylines ( ymg LISP CODE)
« Reply #1 on: September 20, 2017, 07:40:46 AM »
ymg, haven't been active for a past year... I don't know what does this mean, but I am worried about him and I am starting to believe that he isn't available and can not help... We all saw that he replied once after one inactive period and I thought he is still good, but now my hopes are as time passes smaller and smaller...
 :-(
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

pedroantonio

  • Guest
Re: Hatching islands between two polylines ( ymg LISP CODE)
« Reply #2 on: September 20, 2017, 09:19:32 AM »
This is very sad  :-(. Can any one helps me with the code ?

Sudipta2020

  • Mosquito
  • Posts: 2
Re: Hatching islands between two polylines ( ymg LISP CODE)
« Reply #3 on: July 30, 2020, 08:46:58 AM »
CREATE CUT LAYER AND FILL LAYER THEN USE LISP FILE