Créer ses motifs de hachures

[Invité Sylvainhinard]

Bonjour,

 

Je cherche à me creer des motifs de hachures personnalisés. Apparement ce n'est pas très simple sous Autocad (je ne veux pas utiliser la command superhatch de l'Express). J'ai trouvé un Lisp qui à l'air presque... fonctionnel. Les pres du LISP pourrait t-ils regarder de plus près?

 

Merci

 

;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp Hatch Maker © 2005 Larry Schiele

 

;;;* ====== B E G I N C O D E N O W ======

;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation

;;;* Lanny.Schiele@tmisystems.com

;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up.

 

(defun C:DrawHatch (/)

(command "undo" "be")

(setq os (getvar "OSMODE"))

(setvar "OSMODE" 0)

(command "UCS" "w")

(command "PLINE" "0,0" "0,1" "1,1" "1,0" "c")

(command "zoom" "c" "0.5,0.5" 1.1)

(setvar "OSMODE" os)

(setvar "SNAPMODE" 1)

(setvar "SNAPUNIT" (list 0.01 0.01))

(command "undo" "e")

(alert

"Draw pattern within 1x1 box using LINE or POINT entities only..."

)

(princ)

)

 

(defun C:SaveHatch (/ round dxf ListToFile

user SelSet SelSetSize ssNth

Ent EntInfo EntType pt1 pt2

Dist AngTo AngFrom XDir YDir

Gap DeltaX DeltaY AngZone Counter

Ratio Factor HatchName HatchDescr

FileLines FileLines FileName

Scaler ScaledX ScaledY RF x

y h _AB _BC _AC

_AD _DE _EF _EH _FH

DimZin

)

;;;* BEGIN NESTED FUNCTIONS

 

(defun round (num)

(if (>= (- num (fix num)) 0.5)

(fix (1+ num))

(fix num)

)

)

 

(defun dxf (code EnameOrElist / VarType)

(setq VarType (type EnameOrElist))

(if (= VarType (read "ENAME"))

(cdr (assoc code (entget EnameOrElist)))

(cdr (assoc code EnameOrElist))

)

)

 

 

(defun ListToFile (TextList FileName DoOpenWithNotepad

AsAppend / TextItem

File RetVal

)

(if (setq File (open FileName

(if AsAppend

"a"

"w"

)

)

)

(progn

(foreach TextItem TextList

(write-line TextItem File)

)

(setq File (close File))

(if DoOpenWithNotepad

(startapp "notepad" FileName)

)

)

)

(FindFile FileName)

)

 

;;;* END NESTED FUNCTIONS

 

(princ

(strcat

"\n."

"\n 0,1 ----------- 1,1"

"\n | | "

"\n | Lines and | "

"\n | points must | "

"\n | be snapped | "

"\n | to nearest | "

"\n | 0.01 | "

"\n | | "

"\n 0,0 ----------- 1,0"

"\n."

"\nNote: Lines must be drawn within 0,0 to 1,1 and lie on a 0.01 grid."

)

)

(textscr)

(getstring "\nHit [ENTER] to continue...")

 

(princ

"\nSelect 1x1 pattern of lines and/or points for new hatch pattern..."

)

(while (not (setq SelSet (ssget (list (cons 0 "LINE,POINT")))))

)

(setq ssNth 0

SelSetSize (sslength SelSet)

DimZin (getvar "DIMZIN")

)

(setvar "DIMZIN" 11)

(if (> SelSetSize 0)

(princ "\nAnalyaing entities...")

)

(while (< ssNth SelSetSize)

(setq Ent (ssname SelSet ssNth)

EntInfo (entget Ent)

EntType (dxf 0 EntInfo)

ssNth (+ ssNth 1)

)

(cond

((= EntType "POINT")

(setq pt1 (dxf 10 EntInfo)

FileLine (strcat "0,"

(rtos (car pt1) 2 6)

","

(rtos (cadr pt1) 2 6)

",0,1,0,-1"

)

)

(princ (strcat "\n" FileLine))

(setq FileLines (cons FileLine FileLines))

)

((= EntType "LINE")

(setq pt1 (dxf 10 EntInfo)

pt2 (dxf 11 EntInfo)

Dist (distance pt1 pt2)

AngTo (angle pt1 pt2)

AngFrom (angle pt2 pt1)

IsValid nil

)

(if

(or (equal (car pt1) (car pt2) 0.0001)

(equal (cadr pt1) (cadr pt2) 0.0001)

)

(setq DeltaX 0

DeltaY 1

Gap (- Dist 1)

IsValid T

)

(progn

(setq Ang (if (< AngTo pi)

AngTo

AngFrom

)

AngZone (fix (/ Ang (/ pi 4)))

XDir (abs (- (car pt2) (car pt1)))

YDir (abs (- (cadr pt2) (cadr pt1)))

Factor 1

RF 1

)

(cond

((= AngZone 0)

(setq DeltaY (abs (sin Ang))

DeltaX (abs (- (abs (/ 1.0 (sin Ang))) (abs (cos Ang)))

)

)

)

((= AngZone 1)

(setq DeltaY (abs (cos Ang))

DeltaX (abs (sin Ang))

)

)

((= AngZone 2)

(setq DeltaY (abs (cos Ang))

DeltaX (abs (- (abs (/ 1.0 (cos Ang))) (abs (sin Ang)))

)

)

)

((= AngZone 3)

(setq DeltaY (abs (sin Ang))

DeltaX (abs (cos Ang))

)

)

)

(if (not (equal XDir YDir 0.001))

(progn

(setq Ratio (if (< XDir YDir)

(/ YDir XDir)

(/ XDir YDir)

)

RF (* Ratio Factor)

Scaler (/ 1

(if (< XDir YDir)

XDir

YDir

)

)

)

(if (not (equal Ratio (round Ratio) 0.001))

(progn

(while

(and

(<= Factor 100)

(not (equal RF (round RF) 0.001))

)

(setq Factor (+ Factor 1)

RF (* Ratio Factor)

)

)

(if (and (> Factor 1) (<= Factor 100))

(progn

(setq _AB (* XDir Scaler Factor)

_BC (* YDir Scaler Factor)

_AC (sqrt (+ (* _AB _AB) (* _BC _BC)))

_EF 1

x 1

)

(while (< x (- _AB 0.5))

(setq y (* x (/ YDir XDir))

h (if (< Ang (/ pi 2))

(- (+ 1 (fix y)) y)

(- y (fix y))

)

)

(if (< h _EF)

(setq _AD x

_DE y

_AE (sqrt (+ (* x x) (* y y)))

_EF h

)

)

(setq x (+ x 1))

)

(if (< _EF 1)

(setq _EH (/ (* _BC _EF) _AC)

_FH (/ (* _AB _EF) _AC)

DeltaX (+ _AE

(if (> Ang (/ pi 2))

(- _EH)

_EH

)

)

DeltaY (+ _FH)

Gap (- Dist _AC)

IsValid T

)

)

)

)

)

)

)

)

(if (= Factor 1)

(setq Gap (- Dist (abs (* Factor (/ 1 DeltaY))))

IsValid T

)

)

)

)

(if

IsValid

(progn

(setq FileLine

(strcat

(angtos AngTo 0 6)

","

(rtos (car pt1) 2 8)

","

(rtos (cadr pt1) 2 8)

","

(rtos DeltaX 2 8)

","

(rtos DeltaY 2 8)

","

(rtos Dist 2 8)

","

(rtos Gap 2 8)

)

)

(princ (strcat "\n" FileLine))

(setq FileLines (cons FileLine FileLines))

)

(princ (strcat "\n * * * Line with invalid angle "

(angtos AngTo 0 6)

(chr 186)

" omitted. * * *"

)

)

)

)

((princ

(strcat "\n * * * Invalid entity " EntType " omitted.")

)

)

)

)

(setvar "DIMZIN" DimZin)

(if

(and

FileLines

(setq HatchDescr

(getstring T

"\nBriefly describe this hatch pattern: "

)

)

(setq FileName (getfiled "Hatch Pattern File"

"I:\\Acad\\Hatch\\"

"pat"

1

)

)

)

(progn

(if (= HatchDescr "")

(setq HatchDescr "Custom hatch pattern")

)

(setq HatchName (vl-filename-base FileName)

FileLines (cons (strcat "*" HatchName "," HatchDescr)

(reverse FileLines)

)

)

(princ

"\n============================================================"

)

(princ

(strcat "\nPlease wait while the hatch file is created...\n"

)

)

(ListToFile FileLines FileName nil nil)

(command "delay" 1500) ;delay required so file can be created and found (silly, but req.)

(if (findfile FileName)

(progn

(setvar "HPNAME" HatchName)

(princ (strcat "\nHatch pattern '"

HatchName

"' is ready to use!"

)

)

)

(progn

(princ "\nUnable to create hatch pattern file:")

(princ (strcat "\n " FileName))

)

)

)

(princ

(if FileLines

"\nCancelled."

"\nUnable to create hatch pattern from selected entities."

)

)

)

(princ)

)

 

(princ "\n ************************************************************** ")

(princ "\n** **")

(princ "\n* HatchMaker.lsp written by Lanny Schiele -- enjoy! *")

(princ "\n* *")

(princ "\n* Type in DRAWHATCH to have the environment created to draw. *")

(princ "\n* Type in SAVEHATCH to save the pattern you created. *")

(princ "\n** **")

(princ "\n ************************************************************** ")

(princ)

 

[(gile)]

Salut,

 

C'est encore une fois un problème de traduction (anglais -> international)

 

Il suffit de remplacer :

(defun C:DrawHatch (/)

(command "undo" "be")

(setq os (getvar "OSMODE"))

(setvar "OSMODE" 0)

(command "UCS" "w")

(command "PLINE" "0,0" "0,1" "1,1" "1,0" "c")

(command "zoom" "c" "0.5,0.5" 1.1)

(setvar "OSMODE" os)

(setvar "SNAPMODE" 1)

(setvar "SNAPUNIT" (list 0.01 0.01))

(command "undo" "e")

(alert

"Draw pattern within 1x1 box using LINE or POINT entities only..."

)

(princ)

)

par :

(defun c:drawHatch (/)
(command "_undo" "_begin")
(setq os (getvar "OSMODE"))
(setvar "OSMODE" 0)
(command "_ucs" "_w")
(command "_pline" "0,0" "0,1" "1,1" "1,0" "cc")
(command "_zoom" "_c" "0.5,0.5" 1.1)
(setvar "OSMODE" os)
(setvar "SNAPMODE" 1)
(setvar "SNAPUNIT" (list 0.01 0.01))
(command "_undo" "_end")
(alert
"Draw pattern within 1x1 box using LINE or POINT entities only..."
)
(princ)
) 

Ansi que :

(command "delay" 1500) ;delay required so file can be created and found (silly, but req.)

par :

 (command "_delay" 1500) ;delay required so file can be created and found (silly, but req.) 

[kallain]

C'est dommage, ça aurait pu être le [surligneur] Lisp de l'année [/surligneur] :thumbup:

 

Mais il semble être limité : il ne prend pas toutes les lignes

 

Pourquoi ?? Mystère, moi j'ai pas trouvé :casstet:

 

[(gile)]

Voici une version avec les commandes internationalisées et les invites francisées :

EDIT: suppression des bbcodes obsolètes : [surligneur] [/surligneur]

;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp Hatch Maker (c) 2005 Larry Schiele

;;;* ====== B E G I N C O D E N O W ======
;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation
;;;* Lanny.Schiele@tmisystems.com
;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up.

;;; Traduction littérale et approximative des invites en français : Gile

(defun c:drawHatch (/ os)
 (command "_undo" "_begin")
 (setq os (getvar "OSMODE"))
 (setvar "OSMODE" 0)
 (command "_ucs" "_w")
 (command "_pline" "0,0" "0,1" "1,1" "1,0" "_c")
 (command "_zoom" "_c" "0.5,0.5" 1.1)
 (setvar "OSMODE" os)
 (setvar "SNAPMODE" 1)
 (setvar "SNAPUNIT" (list 0.01 0.01))
 (command "_undo" "_end")
 (alert
   "Dessiner le modèle dans un carré de 1x1 \nen utilisant uniquement des POINTS et des LIGNES..."
 )
 (princ)
)

(defun C:SaveHatch (/	     round    dxf      ListToFile
	    user     SelSet   SelSetSize	ssNth
	    Ent	     EntInfo  EntType  pt1	pt2
	    Dist     AngTo    AngFrom  XDir	YDir
	    Gap	     DeltaX   DeltaY   AngZone	Counter
	    Ratio    Factor   HatchName		HatchDescr
	    FileLines	      FileLines		FileName
	    Scaler   ScaledX  ScaledY  RF	x
	    y	     h	      _AB      _BC	_AC
	    _AD	     _DE      _EF      _EH	_FH
	    DimZin
	   )
;;;* BEGIN NESTED FUNCTIONS

 (defun round (num)
   (if	(>= (- num (fix num)) 0.5)
     (fix (1+ num))
     (fix num)
   )
 )

 (defun dxf (code EnameOrElist / VarType)
   (setq VarType (type EnameOrElist))
   (if	(= VarType (read "ENAME"))
     (cdr (assoc code (entget EnameOrElist)))
     (cdr (assoc code EnameOrElist))
   )
 )

 (defun ListToFile (TextList	   FileName	 DoOpenWithNotepad
	     AsAppend	   /		 TextItem
	     File	   RetVal
	    )
   (if	(setq File (open FileName
		 (if AsAppend
		   "a"
		   "w"
		 )
	   )
)
     (progn
(foreach TextItem TextList
  (write-line TextItem File)
)
(setq File (close File))
(if DoOpenWithNotepad
  (startapp "notepad" FileName)
)
     )
   )
   (FindFile FileName)
 )

;;;* END NESTED FUNCTIONS

 (princ
   (strcat
     "\n."
     "\n 0,1 ----------- 1,1"
     "\n |                | "
     "\n | Lignes et      | "
     "\n | points doivent | "
     "\n | être accrochés | "
     "\n | au plus proche | "
     "\n | 0.01           | "
     "\n |                | "
     "\n 0,0 ----------- 1,0"
     "\n."
     "\nNota: Les lignes doivent être dessinées entre 0,0 et 1,1 et sur une grille de 0.01."
    )
 )
 (textscr)
 (getstring "\nTaper [ENTER] pour continuer...")

 (princ
   "\nSelectionnez un modèle de 1x1 constitué de lignes et/ou de points pour un  nouveau motif de hachures..."
 )
 (while (not (setq SelSet (ssget (list (cons 0 "LINE,POINT")))))
 )
 (setq	ssNth	   0
SelSetSize (sslength SelSet)
DimZin	   (getvar "DIMZIN")
 )
 (setvar "DIMZIN" 11)
 (if (> SelSetSize 0)
   (princ "\nAnalyse des entités...")
 )
 (while (< ssNth SelSetSize)
   (setq Ent	  (ssname SelSet ssNth)
  EntInfo (entget Ent)
  EntType (dxf 0 EntInfo)
  ssNth	  (+ ssNth 1)
   )
   (cond
     ((= EntType "POINT")
      (setq pt1      (dxf 10 EntInfo)
     FileLine (strcat "0,"
		      (rtos (car pt1) 2 6)
		      ","
		      (rtos (cadr pt1) 2 6)
		      ",0,1,0,-1"
	      )
      )
      (princ (strcat "\n" FileLine))
      (setq FileLines (cons FileLine FileLines))
     )
     ((= EntType "LINE")
      (setq pt1     (dxf 10 EntInfo)
     pt2     (dxf 11 EntInfo)
     Dist    (distance pt1 pt2)
     AngTo   (angle pt1 pt2)
     AngFrom (angle pt2 pt1)
     IsValid nil
      )
      (if
 (or (equal (car pt1) (car pt2) 0.0001)
     (equal (cadr pt1) (cadr pt2) 0.0001)
 )
  (setq	DeltaX	0
	DeltaY	1
	Gap	(- Dist 1)
	IsValid	T
  )
  (progn
    (setq Ang	  (if (< AngTo pi)
		    AngTo
		    AngFrom
		  )
	  AngZone (fix (/ Ang (/ pi 4)))
	  XDir	  (abs (- (car pt2) (car pt1)))
	  YDir	  (abs (- (cadr pt2) (cadr pt1)))
	  Factor  1
	  RF	  1
    )
    (cond
      ((= AngZone 0)
       (setq DeltaY (abs (sin Ang))
	     DeltaX (abs (- (abs (/ 1.0 (sin Ang))) (abs (cos Ang)))
		    )
       )
      )
      ((= AngZone 1)
       (setq DeltaY (abs (cos Ang))
	     DeltaX (abs (sin Ang))
       )
      )
      ((= AngZone 2)
       (setq DeltaY (abs (cos Ang))
	     DeltaX (abs (- (abs (/ 1.0 (cos Ang))) (abs (sin Ang)))
		    )
       )
      )
      ((= AngZone 3)
       (setq DeltaY (abs (sin Ang))
	     DeltaX (abs (cos Ang))
       )
      )
    )
    (if	(not (equal XDir YDir 0.001))
      (progn
	(setq Ratio  (if (< XDir YDir)
		       (/ YDir XDir)
		       (/ XDir YDir)
		     )
	      RF     (* Ratio Factor)
	      Scaler (/	1
			(if (< XDir YDir)
			  XDir
			  YDir
			)
		     )
	)
	(if (not (equal Ratio (round Ratio) 0.001))
	  (progn
	    (while
	      (and
		(<= Factor 100)
		(not (equal RF (round RF) 0.001))
	      )
	       (setq Factor (+ Factor 1)
		     RF	    (* Ratio Factor)
	       )
	    )
	    (if	(and (> Factor 1) (<= Factor 100))
	      (progn
		(setq _AB (* XDir Scaler Factor)
		      _BC (* YDir Scaler Factor)
		      _AC (sqrt (+ (* _AB _AB) (* _BC _BC)))
		      _EF 1
		      x	  1
		)
		(while (< x (- _AB 0.5))
		  (setq	y (* x (/ YDir XDir))
			h (if (< Ang (/ pi 2))
			    (- (+ 1 (fix y)) y)
			    (- y (fix y))
			  )
		  )
		  (if (< h _EF)
		    (setq _AD x
			  _DE y
			  _AE (sqrt (+ (* x x) (* y y)))
			  _EF h
		    )
		  )
		  (setq x (+ x 1))
		)
		(if (< _EF 1)
		  (setq	_EH	(/ (* _BC _EF) _AC)
			_FH	(/ (* _AB _EF) _AC)
			DeltaX	(+ _AE
				   (if (> Ang (/ pi 2))
				     (- _EH)
				     _EH
				   )
				)
			DeltaY	(+ _FH)
			Gap	(- Dist _AC)
			IsValid	T
		  )
		)
	      )
	    )
	  )
	)
      )
    )
    (if	(= Factor 1)
      (setq Gap	    (- Dist (abs (* Factor (/ 1 DeltaY))))
	    IsValid T
      )
    )
  )
      )
      (if
 IsValid
  (progn
    (setq FileLine
	   (strcat
	     (angtos AngTo 0 6)
	     ","
	     (rtos (car pt1) 2 8)
	     ","
	     (rtos (cadr pt1) 2 8)
	     ","
	     (rtos DeltaX 2 8)
	     ","
	     (rtos DeltaY 2 8)
	     ","
	     (rtos Dist 2 8)
	     ","
	     (rtos Gap 2 8)
	   )
    )
    (princ (strcat "\n" FileLine))
    (setq FileLines (cons FileLine FileLines))
  )
  (princ (strcat "\n * * * Ligne avec angle non valide "
		 (angtos AngTo 0 6)
		 (chr 186)
		 " proscrit. * * *"
	 )
  )
      )
     )
     ((princ
 (strcat "\n * * * Entite non valide " EntType " proscrit(e).")
      )
     )
   )
 )
 (setvar "DIMZIN" DimZin)
 (if
   (and
     FileLines
     (setq HatchDescr
     (getstring	T
		"\nDécrivez brièvement ce motif de hachures: "
     )
     )
     (setq FileName (getfiled "Fichier de hachures"
		      "I:\\Acad\\Hatch\\" ; Chemin du dossier des hachures personnalisées
		       "pat"
		       1
	     )
     )
   )
    (progn
      (if (= HatchDescr "")
 (setq HatchDescr "Modèle de hachures personnalisé")
      )
      (setq HatchName (vl-filename-base FileName)
     FileLines (cons (strcat "*" HatchName "," HatchDescr)
		     (reverse FileLines)
	       )
      )
      (princ
 "\n============================================================"
      )
      (princ
 (strcat "\nAttendez que le fichier de hachures soit créé SVP...\n"
 )
      )
      (ListToFile FileLines FileName nil nil)
      (command "_delay" 1500)		; Délai requis pour que le fichier soit créé et trouvé (stupide, mais requis)
      (if (findfile FileName)
 (progn
   (setvar "HPNAME" HatchName)
   (princ (strcat "\nLe motif de hachures '"
		  HatchName
		  "' est prêt pour l'utilisation !"
	  )
   )
 )
 (progn
   (princ "\nImpossible de créer le fichier de hachures:")
   (princ (strcat "\n " FileName))
 )
      )
    )
    (princ
      (if FileLines
 "\nAbandon."
 "\nImpossible de créer le motif de hachures avec les entités sélectionnées."
      )
    )
 )
 (princ)
)

(princ
 "\n ************************************************************** "
)
(princ "\n** **")
(princ
 "\n* HatchMaker.lsp written by Lanny Schiele -- enjoy! *"
)
(princ "\n* *")
(princ
 "\n* Taper DRAWHATCH pour avoir l'environment de dessin. *"
)
(princ
 "\n* Taper SAVEHATCH pour enregistrer le motif créé. *"
)
(princ "\n** **")
(princ
 "\n ************************************************************** "
)
(princ) 

Nota : On peut remplacer " I:\\Acad\\Hatch\\" par le chemin de son choix (le dossier doit être dans un chemin de recherche des fichiers de support) ou par "" (le dossier par défaut est celui contenu dans la variable DWGPREFIX).

[Edité le 30/10/2005 par (gile)]

[rebcao]

Hello Gilles,

Je te remercie pour ce source Internationalisé...

Par contre, je viens de tester sur un motif très simple (quelques LIGNES) et le programme termine par :

      ; erreur: nombre d'arguments trop important

c'est grave Docteur ? QUID ? le DWG en pièce jointe...

Je te remercie

Christian

TEST_motif_hachure.dwg

[(gile)]

Salut Christian,

Il y avait dans le code des balises bbcode [surligneur] ... [/surligneur] datant de l'ancien CADxp qui ne sont plus reconnues comme balises dans le nouveau CADxp et apparaissaient don "en dur". J'ai corrigé le code ci-dessus, tu peux le re-copier.

Ce genre d'erreur est facile à localiser avec l'éditeur Visual LISP en cochant "Arrêt sur erreur" dans le menu "Débogage",  puis en relançant le code pour générer l'erreur, enfin cliquer sur "Source de la dernière interruption" dans le menu "Débogage" pour sélectionner dans le code l'expression responsable de l'erreur. voir ce screencast.