Discussion :

[FAFAMRX]

Un ancien collègue m'a fourni le lisp en pièce jointe.

Celui-ci a pour but, un calcul de surface de polylignes, inscrire la surface, mettre une hachure de la couleur du calque dans les polylignes.
Il crée deux calques "le nom du calque-TXT" pour la surface et "le nom du calque - Hach) pour la hachure.

Le souci est que les hachures ne se mettent pas de la bonne couleur (celle de la polyligne) (cf : la capture d'écran).

Ma connaissance en lisp étant très limité (plus du bidouillage).

Pourriez-vous me venir en aide pour solutionner ce problème.

Vous remerciant de votre aide.
FAFAMRX

Le LISP:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
(defun c:+coulcalk ()
  (setq coulini (getvar 'cecolor))
  (setq accroini (getvar 'osmode))
  (setq calkini (getvar 'clayer))
  (setq inserUini (getvar 'insunits))
  (setq inserUDefSini (getvar 'insunitsdefsource))
  (setq inserUDefTini (getvar 'insunitsdeftarget))
  (command "scu" "")
  (setvar "cmddia" 0)
  (setvar 'osmode 16416)
  (setvar 'cecolor "BYLAYER")
  (setvar 'insunits 6)
  (setvar 'insunitsdefsource 6)
  (setvar 'insunitsdeftarget 6)
  (setvar 'angbase 0)
  (setq nerr 0)
  (setq total 0)
  (setq ct 0)
  (setq par1 0)
  (setq listcalk nil)
  (setq listsurf '())
  (if (= (getvar 'aunits) 2)
    (setq koef 200)
    (setq koef 180)
  )
  (if ( = (getvar 'angdir) 1)
	  (setq
		rot	(/ (* koef (getvar 'viewtwist) ) pi) ; rotation de la vue exprimée dans l'unité d'angle du dessin
	  )
	 (setq
		rot	(/ (* koef (- 0.0 (getvar 'viewtwist))) pi) ; rotation de la vue exprimée dans l'unité d'angle du dessin
	  )
	)
  (princ "\Selection des surfaces à additionner")
  (setq ss1 (ssget '((0 . "TEXT"))))
  (repeat (sslength ss1)
    (setq nom_ent (ssname ss1 ct))
    (setq ent1 (entget nom_ent))
    (setq d1 (assoc 1 ent1))
    (setq cd1 (cdr d1))
    (while (= "- " (substr cd1 1 2))
      (setq cd1 (strcat "-" (substr cd1 3)))
					; retire les espaces entre le- et les chiffres
    )
    (setq par (read cd1))		; retourne les chiffres
    (if	(and (< (ascii (cdr d1)) 58) (< 44 (ascii (cdr d1))))
      (progn
	(setq coul (cdr (assoc 62 ent1)))
	(setq calk (cdr (assoc 8 ent1)))
	(if (null coul)
	  (setq coul 256)
	)
	(setq total (+ total par))
	(if (assoc calk listsurf)
	  (if (assoc coul (cdr (assoc calk listsurf)))
	    (setq listsurf
		   (subst
		     (cons
		       calk
		       (subst
			 (cons
			   coul
			   (+ par
			      (cdr (assoc coul
					  (cdr (assoc calk listsurf))
				   )
			      )
			   )
			 )
			 (assoc coul (cdr (assoc calk listsurf)))
			 (cdr (assoc calk listsurf))
		       )
		     )
		     (assoc calk listsurf)
		     listsurf
		   )
	    )
	    (setq
	      listsurf (subst (cons calk
				    (cons (cons coul par)
					  (cdr (assoc calk listsurf))
				    )
			      )
			      (assoc calk listsurf)
			      listsurf
		       )
	    )
	  )
	  (progn
	    (setq listsurf (cons (cons calk (list (cons coul par)))
				 listsurf
			   )
	    )
	    (setq listcalk (cons calk listcalk))
	  )
	)
      )
      (setq nerr (1+ nerr))
    )
    (setq ct (+ 1 ct))
  )
  (if (/= 0 nerr)
    (alert
      (strcat "\n" (rtos nerr 2 0) " texte(s) non numérique(s) non pris en compte")
    )
  )
  (princ "\nRésultat de l'addition : ")
  (princ total)
 
  (setq listcalk (acad_strlsort listcalk))
  (if ( = (getvar 'angdir) 1)
	(setq angtxt (angtof (rtos (+ (/ koef 2) rot)) (getvar 'aunits)))
	(setq angtxt (angtof (rtos (-  rot (/ koef 2))) (getvar 'aunits)))
  )
  (setq pt (getpoint "\n Point d'insertion du texte ? "))
  (setq TS (getvar 'TEXTSTYLE))
  (setq totaltext (strcat "Total général= " (rtos total) " m2"))
  (command "_text" "_s" TS "_j" "_m" pt rot totaltext)
  (while (<= 1 (length listcalk))
    (setq StotK 0.0)
    (setvar 'cecolor "BYLAYER")
    (setvar 'clayer (car listcalk))
    (setq pt (polar pt angtxt 1))
    (command "_text"
	     "_s"
	     "surface"
	     "_j"
	     "_m"
	     pt
	     rot
	     (car listcalk)
    )
    (if	(assoc 256 (cdr (assoc (car listcalk) listsurf)))
      (progn
	(setq pt (polar pt angtxt 1))
	(setq totaltext
	       (strcat
		 "Total DUCALQUE = "
		 (rtos
		   (cdr	(assoc 256
			       (cdr (assoc (car listcalk) listsurf))
			)
		   )
		 )
		 " m2"
	       )
	)
	(command "_text" "_s" "surface" "_j" "_m" pt rot totaltext)
	(setq StotK
	       (+ StotK
		  (cdr (assoc 256 (cdr (assoc (car listcalk) listsurf)))
		  )
	       )
	)
      )
    )
    (setq ct 0)
    (while (<= ct 255)
      (if (assoc ct (cdr (assoc (car listcalk) listsurf)))
	(progn
	  (setvar 'cecolor (rtos ct 2 0))
	  (setq pt (polar pt angtxt 1))
	  (setq	totaltext
		 (strcat
		   "Total couleur "
		   (rtos ct 2 0)
		   " = "
		   (rtos
		     (cdr
		       (assoc ct
			      (cdr (assoc (car listcalk) listsurf))
		       )
		     )
		   )
		   " m2"
		 )
	  )
	  (command "_text" "_s" "surface" "_j" "_m" pt rot totaltext)
	  (setq	StotK
		 (+
		   StotK
		   (cdr	(assoc ct (cdr (assoc (car listcalk) listsurf)))
		   )
		 )
	  )
	)
      )
      (setq ct (1+ ct))
    )
    (if	(> (length (cdr (assoc (car listcalk) listsurf))) 1)
      (progn
	(setq pt (polar pt angtxt 1))
	(setq totaltext	(strcat	"Total des surfaces du calque "
				(car listcalk)
				" = "
				(rtos Stotk)
				" m2"
			)
	)
	(setvar 'cecolor "BYLAYER")
	(command "_text" "_s" "surface" "_j" "_m" pt rot totaltext)
      )
    )
    (setq listcalk (cdr listcalk))
  )
  (setvar 'cecolor coulini)
  (setvar 'osmode accroini)
  (setvar 'clayer calkini)
  (setvar 'cmddia 1)
  (setvar 'filedia 1)
  (setvar 'insunitsdefsource inserUDefSini)
  (setvar 'insunitsdeftarget inserUDefTini)
  (setvar 'insunits inserUini)
  (if (< (atoi (getvar "acadver")) 20)
    (command "scu" "p")
    (command-s "scu" "p")
  )