Topograf Online

Un autolisp care va ajuta sa hasurati mai usor!

Autor: Andrea - www.theswamp.org
Se selecteaza polilinia si se scaleaza in timp real. Cu TAB se schimba tipul de hasura.

(http://www.theswamp.org/screens/Andrea/HOSdemo.gif)

=============================
Sursa:
;; ;;
;; H O S COMMAND ;;
;; (Hatch Object Scaling v. 1) ;;
;; By: Andrea Andreetti dec. 2009 ;;
;; ;;
 ;;

(defun c:HOS (/ #DCswitch dr_sel1 entVLA )
(if (not #DCswitch)(setq #DCswitch 0))
(setq dr_sel1 nil)  
  (while (or
           (= dr_sel1 nil)
           (and
           (/= (cdr (assoc 0 (setq dr_sel1data (entget (car dr_sel1))))) "LWPOLYLINE")
           (/= (cdr (assoc 0 (setq dr_sel1data (entget (car dr_sel1))))) "CIRCLE")
           )
         )
(setq dr_sel1 (entsel "\nSlection des lignes du conduit..."))
)
 
(setq entVLA (vlax-ename->vla-object (car dr_sel1)))
(if (or
      (eq (vla-get-ObjectName entVLA) "AcDbCircle")
      (and
      (eq (vla-get-ObjectName entVLA) "AcDbPolyline")
      (eq (vla-get-Closed entVLA) :vlax-true)
      )
    )
  (progn
    
(if (eq (cdr (assoc 0 (setq itemD (entget (Car dr_sel1))))) "CIRCLE")
  (setq centerpoint (cdr (assoc 10 itemD)))
  
;;Get PLINE POINTS ;;
     ;;
(progn (setq fi 0)
       (setq si 1)
       (setq lp (vlax-safearray->list
                  (vlax-variant-value (vla-get-coordinates entvla))
                )
       )
       (repeat (/ (vl-list-length lp) 2)
         (setq plpoints (append plpoints (list (list (nth fi lp) (nth si lp)))))
         (setq fi (+ fi 2))
         (setq si (+ si 2))
       )
       (areapolycentroid plpoints)
)
       ;;
;;Get PLINE POINTS ;;

)
(oHexecute)  
 )
  )
  
  (redraw)
)
 ;;
;; ;;
;; H O S COMMAND ;;
;; (Hatch Object Scaling v. 1) ;;
;; By: Andrea Andreetti dec. 2009 ;;
;; ;;







;; ;;
;; H O S function ;;
;; ;;
 ;;

(defun oHexecute (/ fi si LP)
(setvar "CMDECHO" 0)
(setq nhatch (getvar "HPNAME"))

(setq hatchlist (vl-remove "SOLID" (gethatchlin (findfile "acad.PAT"))))

(setq hatch# (vl-list-length hatchlist))

(vl-cmdf "_-hatch" "_S" (car dr_sel1) "" "")
(setq hatchdata (entget (entlast)))
(if (eq (cdr (assoc 0 hatchdata)) "HATCH")
  (entdel (entlast))
)

(if (/= (assoc 2 hatchdata) "SOLID")
  (progn
    (while (and (setq input (grread t 4 4))
                (or (= (car input) 5)
                    (and (= (car input) 2) (= (cadr input) 9))
                )
           )
;;SWITCH MODE ;;
 ;;
      (if (and (= (car input) 2) (= (cadr input) 9))
        (progn (setq input (grread t 4 4))
               (if (> #dcswitch hatch#)
                 (setq #dcswitch 0)
                 (setq #dcswitch (1+ #dcswitch))
               )
               (princ (strcat "\n- Switched to HATCH : "
                              (setq nhatch (nth #dcswitch hatchlist))
                      )
               )
        )
      )
 ;;
;;SWITCH MODE ;;
      
      ;;PREVIEW
      (ohpreview)
      (princ)
    )
  )
)
(setq hatchent nil)
)
 ;;
;; ;;
;; H O S function ;;
;; ;;





;; ;;
;; H O S Preview ;;
;; ;;
 ;;
(defun ohpreview ()
  (redraw)
  (setq dscale (distance (cadr input) centerpoint))
  (grdraw (cadr input) centerpoint 4 1)
  (setq hatchdatax (subst (cons 41 dscale) (assoc 41 hatchdata) hatchdata))
  (setq hatchdatax (subst (cons 2 nhatch) (assoc 2 hatchdatax) hatchdatax))
  (if (not (assoc 62 hatchdatax))
    (setq hatchdatax (append hatchdatax (list (cons 62 12))))
    (setq hatchdatax (subst '(62 . 12) (assoc 62 hatchdatax) hatchdatax))
  )
  (if hatchent
    (progn (command "_erase" hatchent "") (setq hatchent nil))
  )
  (setq hatchent (entmakex hatchdatax))
)
 ;;
;; ;;
;; H O S Preview ;;
;; ;;






;| ;;
 PAT or LIN file reader ;;
 |;
 ;;
(defun getHatchLIN (acadftype / lino acadftype l1 commaPos ALLLIST)
(setq HATCHLIST nil
      LINESLIST nil)
(if (findfile acadftype)
  (progn
  (setq lino (open acadftype "r"))
  (while (setq l1 (read-line lino))
    (if (and
          (eq (substr l1 1 1) "*")
          (setq commaPos (vl-string-search "," l1))
        )
      (setq ALLLIST (append ALLLIST (list (substr l1 2 (1- commaPos)))))
    )
  )
)
)
(close lino)
(if (eq (strcase (vl-filename-extension acadftype)) ".PAT")
(setq HATCHLIST (mapcar 'strcase ALLLIST))
(setq LINESLIST (mapcar 'strcase ALLLIST))  
)
)
 ;;
;| |;


















;; ;;
;; POLYGON CENTER ;;
;; ;;
 ;;
(defun AREApolycentroid (lp / Xmax Xmin Ymax Ymin sbpt a1 b1)
      (setq Xmax (car (car lp)))
      (setq Xmin (car (car lp)))
      (setq Ymax (cadr (car lp)))
      (setq Ymin (cadr (car lp)))    
(foreach sbpt lp
      (if (> (cadr sbpt) Ymax)(setq Ymax (cadr sbpt)))
      (if (< (cadr sbpt) Ymin)(setq Ymin (cadr sbpt)))
      (if (> (car sbpt) Xmax)(setq Xmax (car sbpt)))
      (if (< (car sbpt) Xmin)(setq Xmin (car sbpt)))
);_foreach
(setq a1 (append (list Xmin)(list Ymin)))
(setq b1 (append (list Xmax)(list Ymax)))    
(setq centerpoint (polar a1 (angle a1 b1) (/ (distance a1 b1) 2)))
)
 ;;
;; ;;
;; POLYGON CENTER ;;
;; ;;












;|«Visual LISP© Format Options»
(120 2 1 2 nil "Ende von " 60 20 1 1 0 nil nil nil T)
;*** NE PAS AJOUTER de texte au-dessous du commentaire! ***|;
Modificat de advex (30-10-2010 16:12:19)

ce bine ai face daca ai pune programelul aici... fara se ne mai pui sa il cautam pe forumul ala...
eu unul nu am gasit de unde sa-l iau...
scuze

Citat din: bstcadce bine ai face daca ai pune programelul aici... fara se ne mai pui sa il cautam pe forumul ala...
eu unul nu am gasit de unde sa-l iau...
scuze

Asta am si facut!
Pe langa semnalarea programului am indicat autorul si continutul autolisp.
Descarcarea directa a programului lisp - hos.lsp - necesita inregistrarea pe forumul www.theswamp.org - si solutia simpla era copierea liniilor de program postate mai sus intr-un fisier hos.lsp deschis cu orice editor de text.

Daca sunt probleme si sunt necesare explicatii suplimentare pot reveni!

Direct se poate descarca de la http://rapidshare.com/files/195602512/HOS.LSP.html

Spor la hasurare!

Tie ti-a mers ? Mie nu. In AutoCAD 2007, da mesaj de eroare ca nu are definita o functie, cred ca Visual Lisp:

Slection des lignes du conduit...; error: no function definition:
VLAX-ENAME->VLA-OBJECT

Modificat de John Doe (09-02-2009 10:15:04)

(http://www.theswamp.org/index.php?action=dlattach;topic=26444.0;attach=11193;image)

De la http://rapidshare.com/files/195873523/Dhatch4.5.LSP.html se poate descarca o versiune imbunatatita.

Comanda: dhatch

Selectia se face cu SPACEBAR, activarea cu ENTER.

Modificat de advex (09-02-2009 11:09:33)

Autocad 2002, nu-mi merge....

advex, la tine merge DHATCH ? In ce program (CAD) lucrezi ?

Pe Autocad 2008 functioneaza f. bine. Am sa incerc si pe 2007.

Bun, astept. Daca va merge la tine, ar trebui sa mearga si pe 2007, teoretic. Intre timp, o sa ma documentez daca sunt diferente intre versiunile Lisp de pe 2007 si 2008.

Functioneaza si pe un alt calculator cu Autocad 2007!



Nu stiu daca functioneaza pe un astfel de Autocad!!!!!!

(http://www.imagehost.ro/pict/0913042549900db900905.gif)

Modificat de advex (09-02-2009 13:04:00)

Acum merge. Cred ca a fost o chestie de setari de-ale mele in AutoCAD, si una de compatibilitate a editoarelor de texte.
Mersi, advex.

Modificat de John Doe (09-02-2009 16:16:46)

Nici mie nu mi-a functionat scriptul postat pe forum ,insa am schimbat eu cateva linii de cod (cele din visual lisp le-am rescris in autolisp) si pare sa mearga... Doar o mica problema, nu stiu de ce nu calculeaza corect centrul de greutate al unor poligoane regulate sau neregulate, insa determina corect centrul cercului (nici nu am insistat sa refac acea parte de cod) . Problema se extinde si la scalare (scalarea o face in functie de pozitia cursorului si coordonatele centrului de greutate , prin codul : (setq dscale (distance (cadr (setq input (grread t 4 4))) centerpoint)) . Cand o sa am timp o sa caut si aici solutia.
Ca urmare ,postez codul direct in format text pe forum ; asa sigur il vor gasi pentru multa vreme aici si altii ,cu permisiune administratorului,desigur :


(defun c:HOS (/ #DCswitch dr_sel1 entVLA )
(if (not #DCswitch)(setq #DCswitch 0))
(setq dr_sel1 nil)
(while (or
         (= dr_sel1 nil)
         (and
         (/= (cdr (assoc 0 (setq dr_sel1data (entget (car dr_sel1))))) "LWPOLYLINE")
         (/= (cdr (assoc 0 (setq dr_sel1data (entget (car dr_sel1))))) "CIRCLE")
         )
       )
(setq dr_sel1 (entsel "\nSlection des lignes du conduit..."))
)

(setq entVLA (entget  (car dr_sel1)))
(if (or
    (eq (cdr(assoc 100 (cdr(member (cons 100  "AcDbEntity") entVLA)))) "AcDbCircle")
    ;(and
    (eq (cdr(assoc 100 (cdr(member (cons 100  "AcDbEntity") entVLA)))) "AcDbPolyline")
   ; (eq (cdr(assoc 70 entVLA)) 1 )
    ;)
  )
(progn
 
(if (eq (cdr (assoc 0 (setq itemD (entget (Car dr_sel1))))) "CIRCLE")
(setq centerpoint (cdr (assoc 10 itemD)))
 
;;Get PLINE POINTS        ;;
                   ;;
(progn (setq fi 0)
     (setq si 1)
     (setq lp (cdr (assoc 10 entvla))
             
     )
     (repeat (/ (vl-list-length lp) 2)
       (setq plpoints (append plpoints (list (list (nth fi lp) (nth si lp)))))
       (setq fi (+ fi 2))
       (setq si (+ si 2))
     )
     (areapolycentroid plpoints)
)
                    ;;
;;Get PLINE POINTS        ;;

)
(oHexecute)
)
)

(redraw)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun oHexecute (/ fi si LP)
(setvar "CMDECHO" 0)
(setq nhatch (getvar "HPNAME"))

(setq hatchlist (vl-remove "SOLID" (gethatchlin (findfile "acad.PAT"))))

(setq hatch# (vl-list-length hatchlist))

(vl-cmdf "_-hatch" "_S" (car dr_sel1) "" "")
(setq hatchdata (entget (entlast)))
(if (eq (cdr (assoc 0 hatchdata)) "HATCH")
(entdel (entlast))
)

(if (/= (assoc 2 hatchdata) "SOLID")
(progn
  (while (and (setq input (grread t 4 4))
              (or (= (car input) 5)
                  (and (= (car input) 2) (= (cadr input) 9))
              )
         )
;;SWITCH MODE            ;;
              ;;
    (if (and (= (car input) 2) (= (cadr input) 9))
      (progn (setq input (grread t 4 4))
             (if (> #dcswitch hatch#)
               (setq #dcswitch 0)
               (setq #dcswitch (1+ #dcswitch))
             )
             (princ (strcat "\n- Switched to HATCH : "
                            (setq nhatch (nth #dcswitch hatchlist))
                    )
             )
      )
    )
              ;;
;;SWITCH MODE            ;;
   
    ;;PREVIEW
    (ohpreview)
    (princ)
  )
)
)
(setq hatchent nil)
)
(defun ohpreview ()
(redraw)
(setq dscale (/ (distance (cadr input) centerpoint) 50))
(grdraw (cadr input) centerpoint 4 1)
(setq hatchdatax (subst (cons 41 dscale) (assoc 41 hatchdata) hatchdata))
(setq hatchdatax (subst (cons 2 nhatch) (assoc 2 hatchdatax) hatchdatax))
(if (not (assoc 62 hatchdatax))
  (setq hatchdatax (append hatchdatax (list (cons 62 12))))
  (setq hatchdatax (subst '(62 . 12) (assoc 62 hatchdatax) hatchdatax))
)
(if hatchent
  (progn (command "_erase" hatchent "") (setq hatchent nil))
)
(setq hatchent (entmakex hatchdatax))
)
(defun getHatchLIN (acadftype / lino acadftype l1 commaPos ALLLIST)
(setq HATCHLIST nil
    LINESLIST nil)
(if (findfile acadftype)
(progn
(setq lino (open acadftype "r"))

(while (setq l1 (read-line lino))
  (if (and
        (eq (substr l1 1 1) "*")
        (setq commaPos (vl-string-search "," l1))
      )
    (setq ALLLIST (append ALLLIST (list (substr l1 2 (1- commaPos)))))
  )
)
)
)
(close lino)
(if (eq (strcase (vl-filename-extension acadftype)) ".PAT")
(setq HATCHLIST (mapcar 'strcase ALLLIST))
(setq LINESLIST (mapcar 'strcase ALLLIST))
)
)
(defun AREApolycentroid (lp / Xmax Xmin Ymax Ymin sbpt a1 b1)
    (setq Xmax (car (car lp)))
    (setq Xmin (car (car lp)))
    (setq Ymax (cadr (car lp)))
    (setq Ymin (cadr (car lp)))  
(foreach sbpt lp
    (if (> (cadr sbpt) Ymax)(setq Ymax (cadr sbpt)))
    (if (< (cadr sbpt) Ymin)(setq Ymin (cadr sbpt)))
    (if (> (car sbpt) Xmax)(setq Xmax (car sbpt)))
    (if (< (car sbpt) Xmin)(setq Xmin (car sbpt)))
);_foreach
(setq a1 (append (list Xmin)(list Ymin)))
(setq b1 (append (list Xmax)(list Ymax)))  
(setq centerpoint (polar a1 (angle a1 b1) (/ (distance a1 b1) 2)))
)

Modificat de DAN.ARBA (30-10-2010 01:46:04)

Completez: doar prima comanda am corectat-o , cea cu numele HOS (pentru cei neavizati, programul e impartit in mai multe subprograme ,astfel incat cea de baza - HOS  - le  apeleaza si pe cele secundare la lansarea in executie)

UPS! se pare ca m-am suprapus cu niste coduri BBC :)))))
corectez de indata!!!

rog administratorul sa elimine aceasta postare !

Modificat de DAN.ARBA (29-10-2010 21:21:30)

... vezi ca ghilimele + paranteza inchisa = ";) pe forum... pune un spatiu intre ele.

am observat , Jhon Doe :) Multumesc!
In plus , i-am dat voie sa hasureze si poliliniile ne-inchise ... Chiar daca sunt inchise geometric/vizual ,unele nu sunt setate ca fiind inchise , iar rutina nu permitea sa fie hasurate si acestea .Deci  n-o sa functioneze pe cele care nu isi ating capetele ,adica merge doar pe cele care se pot hasura .

Modificat de DAN.ARBA (30-10-2010 01:49:57)

Citat din: John Doe... vezi ca ghilimele + paranteza inchisa = ") pe forum... pune un spatiu intre ele.

Pentru a evita aparitia de "smilies" in corpul programelor autolisp este suficient sa fie dezactivata optiunea Converteste smilies in imagini din meniul de postare.

Cu chestiunea asta cu polilinii neinchise e o adevarata poveste... tot sap si eu la ea mai demult, nu i-am dat de capat inca. Ideea este ca vrand sa aflu aria unui contur, dau "boundary" in el si vad aria, dar daca nu e inchis se blocheaza calculatorul. Sau daca are prea multe contururi vecine suprapuse, sau alte numeroase motive.
Am incercat sa-l setez sa ia in calcul mai multe entitati (atunci cand zice "Select everything in visible" ), i-am marit si micsorat variabila HPGAPTOL, tot nu merge. Adica nu-mi dau seama ce ar trebui facut ca sa evit blocarea calculatorului.

@advex: da logic ce spui tu, dar ar trebui o completare: bifa aia apare numai dupa ce postez, daca vreau sa modific textul. Am observat asta fiindca normal ca i-am tras si eu un smilies in mesaj....

John:
Nu exista problema fara rezolvare!

Se recomanda utilizarea tagurilor code, respectiv /code (cu parantezele [] aferente) la incadrarea codurilor sursa din autolisp.

exemplu:

..    :))
Fara tag:
:)

Modificat de advex (30-10-2010 12:54:59)

:nod:

Cautand niste hasuri mai "speciale" pe net, am dat de acest programel gratis, foarte util. Programul se numeste MyHatch, se instaleaza in Autocad si permite practic "desenarea" hasurii si salvarea ei ca fisier .pat. Eu mi-am creat toate hasurile care mi-au trecut prin cap cu acest program.
Link:
http://www.fileshare.ro/23665089012.5

rog pe cineva care are programelul pentru hasura sa il posteze.celelalte nu mai contin programul.va multumesc :hi:

no lines in the hatch .... asta imi da cand vreau sa salvez? trebuie sa aiba o anumita extensie?...caci am desenat ceva in patratul ala albastru.... de ce oare.... autocad 2005

Incearca sa faci hasura ta numai din linii. Sau incearca cu alta versiune de AutoCAD, 2005 nu e cea mai fericita.

                  

Andra a scris: no lines in the hatch .... asta imi da cand vreau sa salvez? trebuie sa aiba o anumita extensie?...caci am desenat ceva in patratul ala albastru.... de ce oare.... autocad 2005

Patratul inchis la culoare (gridul) este pentru a crea hasura, iar patratul albastru este poligonul in care poti sa testezi hasura creata. Ca sa creezi o hasura, deseneaz-o doar cu instrumentele proprii ale programului si doar cu linii, nu polilinii. Ar trebui sa mearga si pe AutoCAD 2005, nu stiu sigur.

Modificat de zamfy (20-07-2011 17:51:31)