;; ;;
;; 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! ***|;
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
(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)))
)
Citat din: John Doe... vezi ca ghilimele + paranteza inchisa = ") pe forum... pune un spatiu intre ele.
.. :))
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 |