multiligne et hachures

[tyrese69_]

Bonjour à tous,

 

Voici une tentative de mise au point d'une petite routine !

Mais mes connaissances en lisp et vlisp me font défaut !

La routine ci aprés ne fonctionne pas elle est "en l'état".

 

Ce que je souhaite faire:

 

Par un jeu de sélection récuperer les multilignes d'une m^me couche par sélection sur un objets, en fonction du nom de la couche, ajouter

 

à celui-ci "-Hath" et mettre un type de hachure à toutes ces multilignes, d'une couleur en accord avec celle de la couche d'origine !

 

Ceci me servirait pour des chemins de câbles dessinés en multilignes et comme cela simplement les hauchres associées seraient créées.

 

Bonne journée A+

 

 

(defun c:selecr ( / ssets acadDocument newsset ctr item filter_code filter_value)

;load the visual lisp extensions

(vl-load-com)

 

(setq VarOsmode (getvar "OSMODE"))

(setq Ccourante (getvar "CLAYER"))

(setvar "OSMODE" 167)

(setvar "cmdecho" 0)

; sauvegarde de la précision initiale

(setq VarLuprec (getvar "LUPREC"))

; précision 0.000 000 00

(setvar "LUPREC" 8)

(command "_-hatch" "p" "ANSI31" "0.04" "0" "")

; Créer des hachures Associatives? [Oui/Non] Non puis Cr Cr

 

; Créer des hachures séparées? [Oui/Non] Non puis Cr Cr

(command "_-bhatch" "A" "H" "o" "" "")

 

; Origine soit: O, "utilise par Défaut l'étendue des contour" soit: D ,

; "Centre" soit: C, stocker en tant qu'origine par défaut ? O/N soit: N puis Cr

(command "_-hatch" "o" "d" "c" "o" "")

 

 

;retrieve a reference to the documents object

(setq acadDocument (vla-get-activedocument

(vlax-get-acad-object)))

;retrieve a reference to the selection sets object

(setq ssets (vla-get-selectionsets acadDocument))

;add a new selection set

;(vla-delete (vla-item ssets "SS1"))

(setq newsset (vla-add ssets "SS1"))

 

;create a single element array for the DXF Code

(setq filter_code (vlax-make-safearray vlax-vbinteger '(0 . 0)))

;create a single element array for the value

(setq filter_value (vlax-make-safearray vlax-vbvariant '(0 . 0)))

;DXF Code for layers

(vlax-safearray-fill filter_code '(0))

;the filter value

(vlax-safearray-fill filter_value '("MLINE"))

; texte de la ligne de commande

(prompt "\nSélectionner une ou des multilignes ! ")

;Use Select on Screen to select objects on Layer 7

(vla-selectOnScreen newsset filter_code filter_value)

;set the counter to zero

(setq ctr 0)

;count the number of objects and loop

(repeat (vla-get-count newsset)

;retrieve each object

(setq item (vla-item newsset ctr))

;check if the entity has a color property

;and it can be updated

(setq check (vlax-property-available-p item "Color" T))

;if it can

(if check

; Récupère it's color

(setq ColorObj (vlax-get-property item 'Color))

);if

;(setq check (vlax-property-available-p item "layer" T))

;if it can

 

; Récupère Layer name

(setq CoucheObj (vla-get-Layer (vla-item newsset 0)))

(setq CoulEnt (cdr (assoc 62 (tblsearch "layer" CoucheObj))))

(alert "toto1")

(command "_-hatch" "a" "a" "n" "" "_s" (ssadd (entlast) ssets) "" "")

 

;increment the counter

(setq ctr (1+ ctr))

);repeat

(setq CalqueHatch (strcat CoucheObj "-Hach"))

 

; changement de calque ou création

(command "_-layer" "e" CalqueHatch "")

; mise à la couleur 31 du calque

(command "_-layer" "co" CoulEnt CalqueHatch "")

;(if ssets

; (command "_-hatch" "a" "a" "n" "" "_s" (ssadd (entlast) ssets) "" "")

;)

 

;delete the selection set

(vla-delete (vla-item ssets "SS1"))

; Restitue la couche courantre

(command "_-layer" "e" Ccourante "")

(setvar "OSMODE" VarOsmode)

(setvar "cmdecho" 1)

 

(princ)

);defun

[lili2006]

Bonjour à toutes et tous,

 

Sinon, _zébulon avait créé cette routine en polyligne, plutôt sympa quand, tout comme toi, on a besoin de hachurer =>

 

 ;;;
;;; lancer une commande autocad

(defun mycmd (LCMD / CMD ETL LELEM RES OLDCMDECHO)
(setq ETL (entlast))
(setq OLDCMDECHO (getvar "CMDECHO"))
(setvar "CMDECHO" 1)
(foreach CMD LCMD
(command CMD)
)
(while (not (zerop (getvar "cmdactive")))
(command pause)
)
(setvar "CMDECHO" OLDCMDECHO)
(setq LELEM nil)
(if (not ETL) 
(setq ETL (entnext))
(setq ETL (entnext ETL))
)
(while ETL
(setq LELEM (cons ETL LELEM))
(setq ETL (entnext ETL))
)
(setq RES LELEM)
)


(defun [surligneur]c: POLYHACH [/surligneur]  (/ D PLENAM PLOBJ OFFSETD OFFSETG PTOD PTFD PTOG PTFG AcDoc Space LO LF)
(vl-load-com)
;; largeur de la polyligne
(setq D (getreal "\nLargeur du voile ? : "))
;; tracer une polyligne
(setq PLENAM (car (mycmd '("_pline"))))
;; transformer en vla-object
(setq PLOBJ (vlax-ename->vla-object PLENAM))
;; faire les décallages
(vla-offset PLOBJ (/ D 2.0)) ; à droite
(setq OFFSETD (vlax-ename->vla-object (entlast)))
(vla-offset PLOBJ (/ D -2.0)) ; à gauche
(setq OFFSETG (vlax-ename->vla-object (entlast)))
; effacer la polyligne d'origine
(vla-erase PLOBJ)
; fermer les extrémités avec des lignes
(setq PTOD (vlax-curve-getStartPoint OFFSETD))
(setq PTFD (vlax-curve-getEndPoint OFFSETD))
(setq PTOG (vlax-curve-getStartPoint OFFSETG))
(setq PTFG (vlax-curve-getEndPoint OFFSETG))

(setq AcDoc (vla-get-activeDocument (vlax-get-acad-object))
Space (if (= (getvar "CVPORT") 1)
(vla-get-PaperSpace AcDoc)
(vla-get-ModelSpace AcDoc) 
)
)
(vla-addLine
Space
(vlax-3d-point PTOD)
(vlax-3d-point PTOG)
)
(setq LO (entlast))
(vla-addLine
Space
(vlax-3d-point PTFD)
(vlax-3d-point PTFG)
)
(setq LF (entlast))
;; on fait un PEDIT "Joindre" avec tout ça
(setvar "peditaccept" 1)
(command "_pedit" "_m" LO (vlax-vla-object->ename OFFSETD) LF (vlax-vla-object->ename OFFSETG) "" "_j" 0.1 "_w" "0.0" "")
;; et enfin on y met une hachure (qu'on peut changer ici)
(command "-fhach" "_p" "_u" "45" D "_n" "_s" (entlast) "" "")
(princ)
) 

 

Tu peux bien sûr gerer ton style de hachures (CF en fin de lisp),

 

Remarque :retirer l'espace entre c: et POLYHACH

[tyrese69_]

Bonsoir,

Merci à lili2006, mais le PB est avec les mutilignes !

 

Voici un deuxième jet, mais les hachures n'apparaissent pas ???

 

ce n'est pas évident de maitriser les vlax ou les vla

 

et de plus nje n'arrive pas a passser en paramètre le nom de ma couche dans:

 

(vlax-safearray-fill filter_value1 '("MLINE" " EL_CFo"))

 

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
(defun c:selecr ( / ssets acadDocument newsset ctr item filter_code filter_value)
;load the visual lisp extensions
(vl-load-com)
(setq VarOsmode (getvar "OSMODE"))
(setq Ccourante (getvar "CLAYER"))
(setvar "OSMODE" 167)
(setvar "cmdecho" 0)
;  sauvegarde de la précision initiale 
(setq VarLuprec (getvar "LUPREC"))
;  précision 0.000 000 00 
(setvar "LUPREC" 8)
(command "_-hatch" "p" "ANSI31" "0.04" "0" "")
 ; Créer des hachures Associatives? [Oui/Non] 	Non puis Cr Cr

 ; Créer des hachures séparées? [Oui/Non] 		Non puis Cr Cr
(command "_-bhatch" "A" "H" "o" "" "")

; Origine soit: O, "utilise par Défaut l'étendue des contour" soit: D , 
; "Centre" soit: C, stocker en tant qu'origine par défaut ? O/N soit: N puis Cr
(command "_-hatch" "o" "d" "c" "o" "")
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
; EFFACE les selections précédement utilisées
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
;retrieve a reference to the documents object
(setq acadObject (vlax-get-Acad-Object))
(setq acadDocument (vla-get-activedocument acadObject))

;retrieve a reference to the selection sets object
(setq ssets (vla-get-selectionsets acadDocument))

(setq flag nil)
(setq flag1 nil)
(setq flag2 nil)
(setq flag3 nil)
(vlax-for item ssets
(if (= (vla-get-name item) "newsset")
	(setq flag T)
);if
(if (= (vla-get-name item) "newsset1")
	(setq flag1 T)
);if
(if (= (vla-get-name item) "SS1")
	(setq flag2 T)
);if
(if (= (vla-get-name item) "SS2")
	(setq flag3 T)
);if
);

(if flag
 	(vla-delete (vla-item ssets "newsset"))
);if
(if flag1
 	(vla-delete (vla-item ssets "newsset1"))
);if
(if flag2
 	(vla-delete (vla-item ssets "SS1"))
);if
(if flag3
 	(vla-delete (vla-item ssets "SS2"))
);if
;add a new selection set
(setq newsset (vla-add ssets "SS1"))
(setq newsset1 (vla-add ssets "SS2"))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
; DEFINIE LES variables pour les filtres
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;create a single element array for the DXF Code
(setq filter_code (vlax-make-safearray vlax-vbinteger '(0 . 0)))
;create a single element array for the value
(setq filter_value (vlax-make-safearray vlax-vbvariant '(0 . 0)))
;DXF Code for layers
(vlax-safearray-fill filter_code '(0))
;the filter value
(vlax-safearray-fill filter_value '("MLINE"))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
; texte de la ligne de commande
(prompt "\nSélectionner une ou des multilignes ! ")

(vla-selectOnScreen newsset filter_code filter_value)

(setq ctr 0)
(repeat (vla-get-count newsset)
;retrieve each object
(setq item (vla-item newsset ctr))

;check if the entity has a color property
;and it can be updated
(setq check (vlax-property-available-p item "Color" T))

(if check
	; Récupère  it's color
	(setq ColorObj (vlax-get-property item 'Color))
);if
; Récupère Layer name
(setq CoucheObj (vla-get-Layer item))
(setq ctr (1+ ctr))
); repeat

(setq CalqueHatch (strcat CoucheObj "-Hach"))
; changement de calque ou création
(command "_-layer" "e" CalqueHatch "")

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;create a single element array for the DXF Code
(setq filter_code1 (vlax-make-safearray vlax-vbinteger '(0 . 1)))
;create a single element array for the value
(setq filter_value1 (vlax-make-safearray vlax-vbvariant '(0 . 1)))
;DXF Code for layers
(vlax-safearray-fill filter_code1 '(0 8))
;the filter value
(vlax-safearray-fill filter_value1 '("MLINE" "EL_CFo"))

(vla-select newsset1 acSelectionSetAll nil nil filter_code1 filter_value1)

(setq ctr 0)

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(setq scl (getvar "hpscale"))
(setq ang (getvar "hpang"))
(setq pname (getvar "hpname"))
(setq hpassoc (if (= (getvar "hpassoc") 1)
			:vlax-true
			:vlax-false))
(setq space (if (= (getvar "cvport") 1)
		(vla-get-paperspace acadDocument)
		(vla-get-modelspace acadDocument)
		))


(setq acsp (vla-get-modelspace acadDocument))

(setq pnm "ANSI31")
(setq ptyp 0)
(setq bas :vlax-true)

(setq htch (vla-addhatch acsp 0 pnm bas))

(setq olp newsset1)
;(car (entsel "\n\t***\tselect contour \t*** \n"))))


(vla-highlight olp :vlax-true)


;(setq hatch (vlax-invoke space 'addhatch acHatchObject pname hpassoc))
(setq hobj (vlax-make-safearray vlax-vbobject '(0 . 0)))



(vlax-for ent (vla-get-activeselectionset acadDocument)
(setq oname (strcase (vla-get-objectname ent)))
(if (= oname "ACDBMLINE" )
	(progn	
		;(setq hatch (vlax-invoke space 'addhatch acHatchObject pname hpassoc))
		;(vlax-invoke hatch 'appendouterloop (list ent))
		;(vlax-put hatch 'patternangle ang)
		;(vlax-put hatch 'patternscale scl)
		
		(setq hatch (vla-addhatch space 0 pnm bas))
		(vla-put-patternscale hatch 250.) ;scale
		(vla-put-patternangle hatch (* pi 0.125)) ;angle
		(vla-highlight olp :vlax-false)
		
		;(vla-evaluate hatch)
		(vla-update hatch)
		(vla-clear (vla-get-activeselectionset acadDocument))
		(vla-delete (vla-get-activeselectionset acadDocument))
		(mapcar (function (lambda (x)
		(if (not (vlax-object-released-p x))
		(vlax-release-object x))))
		(list olp (vla-get-activeselectionset acadDocument) hatch))
		(vla-regen acadDocument acactiveviewport)
	)
)
)
);defun

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Restitue la couche courantre
(command "_-layer" "e" Ccourante "")
(setvar "OSMODE" VarOsmode)
(setvar "cmdecho" 1)

(princ "Fin routine Hachures CDC")
);defun

[lili2006]

Re,

 

Oui, j'ai bien vu que tu parlais de mligne,...

 

Je m'en sers souvent aussi, mais ce lisp est pas mal du tout et m'en sers pour faire des voiles,...

 

Désolé de ne pouvoir t'aider,.

 

Mais d'autres ici vraisemblablement, ;)