Ajutor la hasurare

[advex]

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.



=============================
Sursa:

Cod [Selectează] Extinde

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

[bstcad]

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

[advex]

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

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!

[John Doe]

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)

[advex]

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)

[moholea]

Autocad 2002, nu-mi merge....

[John Doe]

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

[advex]

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

[John Doe]

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.

[advex]

Functioneaza si pe un alt calculator cu Autocad 2007!



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



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

[John Doe]

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)

[DAN.ARBA]

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 :

Cod [Selectează] Extinde

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

[DAN.ARBA]

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)

[DAN.ARBA]

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

[DAN.ARBA]

rog administratorul sa elimine aceasta postare !

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