Buat Boundary Hatch Otomatis Dengan Autolisp

Sebelum nya saya pernah mendapat tugas membuat back up data Cut and Fill yang di mana mengharuskan saya menghitung luas penampang jalan satu per satu untuk mendapatkan koordinat beserta luasan nya untuk di masukan ke dalam format back up data di excel.

Kemudian yang saya perlukan adalah sebuah polyline tertutup yang menjadi area cut and fill dalam setiap potongan jalan.Sebenar nya kita bisa buat satu per satu polyline mengikuti area cut and fill,Tapi bagaimana jika kita harus membuat ribuan polyline ? Tentu nya akan membuthkan banyak waktu dan melelahkan.

Disini saya akan beri Autolisp untuk membuat Boundary dari semua hatch yang ada di gambar yang berupa Polyline tertutup.

Pertama tama silahkan anda copy paste script autolisp di bawah ini ke dalam notepad kemudian kalian save dengan nama " Boundary.lsp "

;;; Bulk-recreate-hatch-boundaries.lsp
;;; v.2.0 by toni @ http://gistncase.blogspot.com
;;;
;;; This Autolisp routine is intended solely for Dwg to Gis conversion purposes.
;;;
;;; It will recreate boundaries around all the hatch patterns in a drawing at once.
;;; The recreated boundaries will be drawed in custom new layers and will consist
;;; only of closed simple polylines (thus interpreted as polygons by Gis drivers).
;;; Tested on Autocad 2012.
;;; 
;;; Features:
;;; - creates closed-polyline boundaries (Gis polygons)
;;; - assigns the same hatch color to the boundary
;;; - draws in new (property cloned) layers with custom names 
;;; - can delete all the previous boundaries
;;; - handles every kind of known boundary path data
;;; 
;;; credits:
;;; Lee Mac @ http://www.cadtutor.net/forum/showthread.php?49122-Converting-SPlines-to-lines&p=334674#post334674
;;; Murray Clack @ http://forums.autodesk.com/t5/Visual-LISP-AutoLISP-and-General/Recreate-multiple-hatch-boundaries-as-polygons-each-in-the-layer/td-p/3275725/page/2
;;; Autodesk, Inc. @ http://www.cadtutor.net/forum/showthread.php?46610-Use-Entmake-to-create-layer-with-colour-set-to-Truecolour
;;; Jimmy Bergmark @ http://www.jtbworld.com/lisp/hatchb.htm
;;; VVA @ http://www.cadtutor.net/forum/showthread.php?12493-lisp-for-converting-ellipse-to-polylines

(prompt "\nEnter BULKRHB to execute")

(defun c:BULKRHB ( /  dorctl osmode pltype cmecho j
                      SPLINECONVERSIONVALUE BUTTDISTANCETOLERANCE)
  (vl-load-com)
    
  (defun ent2pline ( ent step / etyp pts cdst leng ret )
    ; ent2pline: converts *any* entity to a segmented lwpolyline (no input check)
    ;            returns the new object entity name and deletes the former.
    ;            the lamba function is inspired by a public domain snippet by Lee Mac
    ;            (should be optimized "pinning" the known vertexes or much better
    ;            performing a _pedit-like "smart" conversion...)
    ;
    ;            ent2pline entityname intvalue
    ;                      entityname : dxf entity name (might be *any*)
    ;                      intvalue   : segment max length in case of ellipse, circle 
    
    (setq etyp (vlax-get-property (vlax-ename->vla-object ent) 'ObjectName))
    
    (cond
      ((or (= etyp "AcDbPolyline"))
        (setq ret ent)
      )
      ((= etyp "AcDb2dPolyline")
        (progn
          (command "_.CONVERTPOLY" "_L" (ssadd ent) "")
          (setq ret ent) ;convertpoly won't create a new entity
        )
      )
      ((or (= etyp "AcDbLine") (= etyp "AcDbArc"))
        (progn
          (command "_.PEDIT" (ssadd ent) "_Y" "")
          (setq ret (entlast))
        )
      )
      ((= etyp "AcDbSpline")
        (progn
          (command "_.PEDIT" (ssadd ent) "_Y" SPLINECONVERSIONVALUE "")
          (setq ret (entlast))
        )
      )
      ((or (= etyp "AcDbCircle") (= etyp "AcDbEllipse"))
        (progn
          (setq cdst 0)
          (setq leng (vlax-curve-getDistatParam ent (vlax-curve-getEndParam ent)))
          
          (if (<= leng step)
            (setq step (/ leng 12))
          ); when step is less than obj length "simplify to twelve segs" 
            
          (while (< cdst leng)
            (setq pts  (cons (vlax-curve-getPointatDist ent cdst) pts)
                  cdst (+ step cdst)
            )
          )
            
          (setq pts (cons (vlax-curve-getPointatDist ent leng) pts))

(entmake (append (list (cons 0   "LWPOLYLINE")
                                 (cons 100 "AcDbEntity")
                                 (cons 100 "AcDbPolyline")
                                 (cons 90 (length pts))
                                 (cons 70 0)
                                 (assoc 8 (entget ent)))
                           (mapcar (function (lambda ( a ) (cons 10 a))) pts)))
          (entdel ent)
          (setq ret (entlast))
        )
      )
      ( T
        ;skipping anything else, eg.: "AcDbText", "AcDbMText" (in progress...)
        (progn
          (princ (strcat "Warning: skipping object " (cdr (assoc 5 (entget ent))) " in boundary building, type " etyp " (hatch " (cdr (assoc 5 (entget *ent))) ")\n" ))
          (setq ret nil)
        )
      )      
    )
    ret
  )
  
  (defun smartclosepline ( ent / vlent ctry ret cflg stpt enpt)
    ; smartclosepline: close a polyline when startpoint = endpoint, return
    ;                  0 success or is already closed
    ;                  1 endpoint != startpoint, won't close
    ;                  2 fail
    ;                  nil on nil input
    ;
    ;                  smartclosepline entityname
    ;                                  entityname : dxf entity name (should be a pline)
    
    (if ent
      (progn
        (setq vlent (vlax-ename->vla-object ent)
              cflg  (vlax-get-property vlent 'Closed)
              stpt  (vlax-curve-getStartPoint ent)
              enpt  (vlax-curve-getEndPoint ent))
        
        (cond
          ((= cflg :vlax-true) ;is closed
            (setq ret 0)
          )
          ;((and (= cflg :vlax-false) (equal stpt enpt 0.001)) ;not closed, comparing startpt endpt with a 0.001 precision factor
          ((and (= cflg :vlax-false) (< (distance stpt enpt) BUTTDISTANCETOLERANCE)) ;closable: not closed with startpt endpt within tolerance 
            (progn
              (setq ctry (vl-catch-all-apply 'vla-put-closed (list vlent :vlax-true)))
              (if (or (vl-catch-all-error-p ctry) (eq (vlax-get-property vlent 'Closed) :vlax-false))
                (setq ret 2) ;true
                (setq ret 0) ;false
              )
            )
          )
          ( T ;leave it open, stpoint not coincident with endpt
            (setq ret 1)
          )
        )
      )
      (setq ret nil)
    )
    ret
  )

(defun makesewnboundary ( ent / i r sent nent entd sset0 ssetG ssetX ssetB ssetR)
    ; makesewnboundary: creates a single closed lwpline for each path of the hatch boundary
    ;                   returns a select set with all the closed lwpolylines
    ;
    ;                   makesewnboundary entityname
    ;                                    entityname : dxf entity name (must be hatch)
    
    (setq entd (entget ent))
    (setq sset0 (ssadd)
          ssetG (ssadd)
          ssetX (ssadd)
          ssetB (ssadd)
          ssetR (ssadd))
    
    (if (= *htcpol "Recreate")
      ;deletes all referenced boundary objects
      (mapcar '(lambda (p) 
                  (if (entget p) ;sometimes fake refrences
                    (entdel p)
                  )
                )
                (vl-remove nil
                  (mapcar '(lambda (g)
                              (if (= (car g) 330)
                                (cdr g)
                              )
                            )
                            (reverse (member (assoc 91 entd) entd)) ;from the end to the beginning of loops (91)
                  )
                ) ; list of all the boundary path data references
      )
    )
    
    (setq nent (entlast))
    (command "_.HATCHEDIT" ent "_B" "_P" "_N") ; *non* associative - use HATCHEDIT legacy command instead of HATCHGENERATEBOUNDARY
    
    (while (setq nent (entnext nent))
      (ssadd nent sset0)
    ) ;grabs all the new entries
    
    (if (> (sslength sset0) 0)
      (progn
        (setq i -1)
        (while (setq sent (ssname sset0 (setq i (1+ i))))
          (if (/= (cdr (assoc 0 (entget sent))) "LWPOLYLINE")
            (setq sent (ent2pline sent *step))
          )
          
          (setq r (smartclosepline sent))
          
          (cond
            ((= r 0)
              (ssadd sent ssetG) ;sset GOOD : already closed polylines
            )
            ((= r 1)
              (ssadd sent ssetX) ;sset X    : polyline pieces to be joined
            )
            ((= r 2)
              (progn
                (ssadd sent ssetB) ;sset BAD  : troublesome polylines with stpt = endpt, unable to be closed
                (princ (strcat "Warning: unable to close virtually closed polyline " (cdr (assoc 5 (entget sent))) " (hatch " (cdr (assoc 5 (entget *ent))) ")\n" ))
              )
            )
          )
        )
      )
      (princ (strcat "Error: cannot find or generate boundary entities for hatch handle " (cdr (assoc 5 (entget *ent))) ")\n" ))
    )
    
    (if (> (sslength ssetX) 0)
      ; make the lwpolyline full merge, if any element
      (progn
        (command "_.PEDIT" "_M" ssetX "" "_J" "_J" "_B" "3" "") ;tolerance 3 units, extend and add ("both" join type)
        
        (setq i -1)
        (while (setq sent (ssname ssetX (setq i (1+ i))))
          ; when running PEDIT w/JOIN command some entities are extended while others deleted
          ; so we collect in ssetR all the new closed lwpoly filtering the existing ones from
          ; the previous sset and try a final closing
          (if (entget sent)
            (progn
              (setq r (smartclosepline sent))

(cond
                ((= r 1)
                  (princ (strcat "Warning: unclosable polyline " (cdr (assoc 5 (entget sent))) " (hatch " (cdr (assoc 5 (entget *ent))) ")\n" ))
                )
                ((= r 2)
                  (princ (strcat "Warning: unable to close virtually closed polyline " (cdr (assoc 5 (entget sent))) " (hatch " (cdr (assoc 5 (entget *ent))) ")\n" ))
                )
              )              
              
              (ssadd sent ssetR)
            )
          )
        )
      
      )
    )
    
    ; add already closed lwplines to ssetR
    (setq i -1)
    (while (setq sent (ssname ssetG (setq i (1+ i))))
     (ssadd sent ssetR)
    )
    
    ; add troublesome lwplines to ssetR (here we should do something in the future)
    (setq i -1)
    (while (setq sent (ssname ssetB (setq i (1+ i))))
     (ssadd sent ssetR)
    )

;return
    ssetR
  )
  
  (defun colorandsettle ( sset / i vent sent vsent vslay vtlay slayn tlayn)
    ; colorandsettle: move to layer and put colour to entities of a select set
    ;                 colour is the hatch original color, layer colud be a new layer
    ;
    ;                 colorandsettle selectset
    ;                                selectset : dxf entities selectset
    
    (if (> (sslength sset) 0)
      (progn
        
        (setq vent (vlax-ename->vla-object *ent)) ;visual object of the hatch
        (setq slayn (vla-get-layer vent))         ;hatch layer name
        (setq i -1)
    
        (setq vslay (vla-item *lyrtbl slayn))   ;visual object of the layer of the hatch
        (setq tlayn (strcat slayn "_" *lyrsuf)) ;target layername
        
        (if (not(tblsearch "LAYER" tlayn))
          (progn
            (setq vtlay (vla-add *lyrtbl tlayn))
            (vla-put-truecolor vtlay (vla-get-truecolor vslay))
          )
        )

(while (setq sent (ssname sset (setq i (1+ i))))
          (setq vsent (vlax-ename->vla-object sent))
          (vla-put-truecolor vsent (vla-get-truecolor vent)) ;put the hatch color
          (vla-put-layer vsent tlayn) ;put the new layer
        )
      )
    )
  )
  
  ;
  ; **MAIN**
  ;
  
  ;CONSTANTS
  (setq SPLINECONVERSIONVALUE "15") ;string, *not* integer
  (setq BUTTDISTANCETOLERANCE 0.1) ;float
  
  ;GLOBALS
  (setq *step (cond (*step) (50)))
  (setq *lyrsuf (cond (*lyrsuf) ("BOUNDARIES")))
  (setq *htcpol (cond (*htcpol) ("Add")))
  (setq *doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq *lyrtbl (vla-get-layers *doc))
  
  ;SYSVARS
  (setq dorctl  (getvar "DRAWORDERCTL")
        osmode  (getvar "OSMODE")
        pltype  (getvar "PLINETYPE")
        cmecho  (getvar "CMDECHO"))
        
  (setvar "DRAWORDERCTL" 0)
  (setvar "OSMODE" 0)
  (setvar "PLINETYPE" 2)
  (setvar "CMDECHO" 0)

;INPUT
  (initget "Recreate Add")
  (setq *htcpol (cond ((getkword (strcat "\nDelete and recreate all previous boundaries or simply add the new ones [Recreate/Add] <" *htcpol "> : "))) (*htcpol)))
  (princ *htcpol )
  (initget 128)
  (setq *lyrsuf (cond ((getkword (strcat "\nSuffix for boundary layers name (eg. typing \"BOUNDARIES\" would be: mylayer -> mylayer_BOUNDARIES) <" *lyrsuf "> : "))) (*lyrsuf)))
  (princ *lyrsuf)
  (initget 6)
  (setq *step (cond ((getint (strcat "\nSpecify segments length when breaking elliptic objects <" (itoa *step) "> : "))) (*step)))
  (princ (itoa *step))
  
  ;BULKRHB
  (setq *sset (ssget "_X" (list (cons 0 "HATCH"))))
  (setq j -1)
  
  (if *sset
    (while (setq *ent (ssname *sset (setq j (1+ j))))
      (colorandsettle (makesewnboundary *ent))
    )
  )
 
  (setvar "OSMODE" osmode)
  (setvar "CMDECHO" cmecho)
  (setvar "PLINETYPE" pltype)
  (setvar "DRAWORDERCTL" dorctl)
  (princ)
)

Jika sudah di save sekarang kita kembali ke autocad untuk memasukan autolisp tadi yang sudah di save.Berikut cara nya :

Di menu Command silahkan ketik APPLOAD
Kemudian pilih file Boundary.lisp yang sudah di save tadi.
Lalu Klik Load
kemudian pilih salah satu

Always Load = Untuk selalu me Load Autolisp itu ketika membuka gambar.
Load Once = Untuk meload sementara saja (anda harus me load ulang ketika gambar di close)

jika sukses akan mucul tulisan Boundary.lisp seccesfully loded
kemudian klik close

Selanjut nya adalah kita akan memberi semua hatch yang ada di dalam gambar secara otomatis.

Di menu Command ketikan perintah BULKRHB
Enter
Lalu ketik Add
Enter 3x
Selesai silahkan cek semua hatch sekarang sudah mempunyai boundary semua

Untuk merubah warna nya silahkan klik salah satu boundary kemudian,klik kanan lalu select semiliar kemudian ganti warna nya melalui kolom properties.
Contoh gambar saya yang sudah jadi boundary nya saya menggunakan warna kuning untuk boundary nya.

Berikut Video nya :

Note :

Anda juga bisa meninggal kan jejak dengan berkomentar di kolom komentar di bawah.
Terima kasih semoga bermanfaat :)

Buat Boundary Hatch Otomatis Dengan Autolisp

Related Posts

Posting Komentar

Posting Komentar

Playlist Video

Label

Popular