bloquer une seule page excel avec vbscript ?

**pitchalov** · 04/04/2007, 11h26

Bonjour

Alors voilà mon nouveau problème.

Mon script vbs d'exécution assez longue rentre des informations dans une page excel.

J'ai 2 problèmes qui subsistent :

- Si je ne bloque pas l'application avec l'option Interactive=false, un clic dans la page excel durant l'exécution génère une erreur. Mais si il y a cette option, toutes les pages d'excell ouvertes en parallèle (et donc n'ayant rien à voir avec le script) sont aussi bloquées.

De plus, cette option ne me permet pas de réduire la fenêtre, ou de me servir de la barre de défilement (plus de vision de ce qui est rentré à partir d'un certain nombre de données).

- Je peux aussi empêcher de cliquer sur la page avec l'option screenupdating=false, mais elle aussi s'applique à toutes les fenêtres de l'application et elle aussi empêche de voir les résultats rentrés.
De plus dans ce cas là, si on ouvre une autre fenêtre Excel pendant l'écriture, une erreur est générée. ReDe plus, si je ferme la fenêtre excel qu'utilise le script, le script part en boucle infinie

Y aurait-il une autre manière de m'y prendre que je n'aurais pas envisagé?
ou une façon différente de se servir de ces options?

Merci

**omen999** · 04/04/2007, 12h44

bonjour,

Interactive et ScreenUpdating sont des propriétés de l'objet Application, il est donc logique que leur action s'exerce sur toutes les pages ouvertes d'excel.

pourquoi ne pas lancer une autre instance d'excel pour travailler en parallèle ?

**pitchalov** · 04/04/2007, 14h43

pourquoi ne pas lancer une autre instance d'excel pour travailler en parallèle ?

Je ne sais pas de quoi tu parles, mais je veux bien essayer. tu peux m'en dire un peu plus?

**omen999** · 04/04/2007, 15h47

en clair, ça veut dire lancer une deuxième fois excel à partir du menu ou du raccourci

**pitchalov** · 04/04/2007, 16h29

Alors oui effectivement, je suis d'accord avec toi, dans ce cas ça marche.

Le problème c'est que déjà il faut y penser, c'est à dire si mon script met 20 min à récupérer des infos sur 5000 répertoires, 15 minutes après l'avoir lancé il faut se rappeler qu'il faut pas ouvrir un autre fichier Excel...

Et puis ce script peut être utilisé par d'autres personnes que moi, ce qui implique qu'il doive fonctionner sans ces quelques bugs; ou avec les bugs les moins gênants possible (dans ce cas là, le blocage de l'application

).

Mais si il y a un moyen d'éviter tout ça, ce serait super.
Si quelqu'un a une idée, ou s'est déjà trouvé face à ce problème, je suis très intéressé.

Merci

**ThierryAIM** · 04/04/2007, 17h17

Si je me réfère à ton autre post (faut vraiment tout faire ici

), et si tu utilises Activesheet, alors, tu as sûrement des problèmes ...
Fais voir ton script tel qu'il est écrit maintenant, stp ?

**pitchalov** · 04/04/2007, 17h45

Ok je te poste mon script.

Je l'ai un peu allégé (je t'ai épargné les déclarations, suppressions de variables, fonction quitter et enregistrement à la fin, qui ne serviront à rien pour résoudre ce problème).

Mais il est toujours très long.
Normalement il fonctionne (chez moi oui en tout cas), mais avec les problèmes cités au-dessus:

Mon script :

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
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
Const SE_DACL_PRESENT = &h4
Const ACCESS_ALLOWED_ACE_TYPE = &h0
Const ACCESS_DENIED_ACE_TYPE  = &h1
 
Const FOLDER_ADD_SUBDIRECTORY = &h000004
Const FILE_DELETE             = &h010000
Const FOLDER_TRAVERSE         = &h000020
Const FILE_READ_ATTRIBUTES    = &h000080
Const FILE_READ_CONTROL       = &h020000
Const FOLDER_LIST_DIRECTORY   = &h000001
Const FILE_READ_EA            = &h000008
Const FILE_WRITE_EA           = &h000010
Const FILE_SYNCHRONIZE        = &h100000
Const FILE_WRITE_ATTRIBUTES   = &h000100
Const FILE_WRITE_DAC          = &h040000
Const FOLDER_ADD_FILE         = &h000002
 
Const COLOR_ERREUR = 16
Const COLOR_ECRITURE = 35
Const COLOR_LECTURE = 40
Const COLOR_PARTICULIER = 39
 
Const LIGNE_GROUPE = 3
Const LIGNE_DEBUT = 6
Const COLONNE_NIVEAU1 = 1
Const COLONNE_NIVEAU2 = 2
Const COLONNE_NIVEAU3 = 3
Const COLONNE_NIVEAU4 = 4
 
Const xlLightDown = 13
Const xlAutomatic = 0
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Fonction Recup_sous_repertoires() :  permet de récupérer tous les sous-répertoires de niveau nivMax du chemin passé en paramètre (chemin)
'
Sub Recup_sous_repertoires(chemin, niveau)
 
	' Option : Ne pas stopper le programme en cas d'erreur
	On Error Resume Next
 
	' Dédinition des variables de la fonction
	Dim rep
	Dim sousrep
	Dim folder
 
	Set rep = objFso.GetFolder(chemin)
	Set sousrep = rep.SubFolders
 
	' Recherche de tous les dossiers de niveau 1
	For Each folder in sousrep
 
		'WScript.Echo "folder name : " & folder.name
 
		strFolderName = folder.name
		If Err.Number <> 0 Then
			strFolderName = ""
			Err.Clear
		End If
 
 
		objWorkBook.ActiveSheet.Cells(intRow, COLONNE_NIVEAU1 + niveau).Value = strFolderName
 
		If Err.Number <> 0 Then
			WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
			WScript.Quit
		End If
 
		intCol = colonneDebut
		testErreur = COLONNE_NIVEAU1 + niveau
 
		Recup_Droits folder
 
		intRow = intRow + 1
 
		'WScript.Echo "nivMax = " & nivMax & " ; niveau = " & niveau
 
		If niveau < nivMax - 1 Then
			Recup_sous_repertoires folder, niveau + 1
		End If
	Next
	'WScript.Echo "Sortie du niveau " & niveau & " de la fonction Recup_sous_repertoires" 
 
	' Libération des variables
	Set rep = Nothing
	Set sousrep = Nothing
	Set folder = Nothing
End Sub
''''''''''''''''''''''''''''''
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Fonction Recup_Droits() : permet de récupérer les droits NTFS du dossier passé en paramètre (folder)
'
Sub Recup_Droits(folder)
 
	' Option : Ne pas stopper le programme en cas d'erreur
	On Error Resume Next
 
	' Dédinition des variables de la fonction
	Dim objFolderSecuritySettings
	Dim intRetVal
	Dim intControlFlags
	Dim objSD
	Dim arrACEs
	Dim objACE
 
	' Dans la chaîne folder, on remplace tous les '\' par "\\"
	folder = Replace(folder, "\", "\\")
 
	' Récupération des droits NTFS du dossier folder
	Set objFolderSecuritySettings = objWMIService.Get("Win32_LogicalFileSecuritySetting=""" & folder & """")
 
	If Err.Number <> 0 Then	
		objWorkBook.ActiveSheet.Cells(intRow, testErreur).Interior.ColorIndex = COLOR_ERREUR
		Err.Clear
 
	Else
		intRetVal = objFolderSecuritySettings.GetSecurityDescriptor(objSD)
 
		intControlFlags = objSD.ControlFlags
 
		If intControlFlags AND SE_DACL_PRESENT Then
			arrACEs = objSD.DACL
 
			For Each objACE in arrACEs
 
				If (objACE.Trustee.Name <> "Administrateurs") AND (objACE.Trustee.Name <> "SYSTEM") Then
					testIsPresent = false
					i = colonneDebut
 
					Do While (objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, i).Value <> "" )
 
						If (objACE.Trustee.Name = objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, i).Value) Then
							testIsPresent = true
							intCol = i
						End If
						i = i + 1
					Loop
 
					If testIsPresent = false Then
						intCol = i
						objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, intCol).Value = objACE.Trustee.Name
						'WScript.Echo "Nouveau groupe trouvé : " & objACE.Trustee.Name
 
						objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, intCol).Orientation = 90
						objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, intCol).Activate
						Set objRange = objExcel.ActiveCell.EntireColumn
						objRange.Autofit()
 
					End If
 
					If objACE.AccessMask AND FOLDER_TRAVERSE Then
 
						If objACE.AccessMask AND FILE_READ_ATTRIBUTES Then
 
							If objACE.AccessMask AND FILE_READ_EA Then
 
								If objACE.AccessMask AND FOLDER_LIST_DIRECTORY Then
 
									If objACE.AccessMask AND FILE_WRITE_EA Then
 
										If objACE.AccessMask AND FILE_DELETE Then
 
											If objACE.AccessMask AND FILE_WRITE_ATTRIBUTES Then
 
												If objACE.AccessMask AND FOLDER_ADD_FILE Then
													objWorkBook.ActiveSheet.Cells(intRow, intCol).Interior.ColorIndex = COLOR_ECRITURE
													objWorkBook.ActiveSheet.Cells(intRow, intCol).Value = ""
													If Err.Number <> 0 Then
														WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
														WScript.Quit
													End If
												End If
											End If
										End If
 
									Else
										objWorkBook.ActiveSheet.Cells(intRow, intCol).Interior.ColorIndex = COLOR_LECTURE
										objWorkBook.ActiveSheet.Cells(intRow, intCol).Interior.Pattern = xlLightDown
										objWorkBook.ActiveSheet.Cells(intRow, intCol).Value = ""
										If Err.Number <> 0 Then
											WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
											WScript.Quit
										End If
									End If
								End If
							End If
						End If
 
					Else
						objWorkBook.ActiveSheet.Cells(intRow, intCol).Interior.ColorIndex = COLOR_PARTICULIER
 
						strDroits = ""
 
						If objACE.AccessMask AND FOLDER_TRAVERSE Then
							strDroits = strDroits & "Parcours du dossier / exécuter le fichier" & " ; "
						End If
 
						If objACE.AccessMask AND FOLDER_LIST_DIRECTORY Then
							strDroits = strDroits & "Liste du dossier / lecture de données" & " ; "
						End If
 
						If objACE.AccessMask AND FILE_READ_ATTRIBUTES Then
							strDroits = strDroits & "Attributs de lecture" & " ; "
						End If
 
						If objACE.AccessMask AND FILE_WRITE_EA Then
							strDroits = strDroits &  "Création de fichiers / écriture de données" & " ; "
						End If
 
						If objACE.AccessMask AND FOLDER_ADD_FILE Then
							strDroits = strDroits & "Création de dossier / ajout de données" & " ; "
						End If	
 
						If objACE.AccessMask AND FILE_WRITE_ATTRIBUTES Then
							strDroits = strDroits & "Attributs d'écriture" & " ; "
						End If
 
						If objACE.AccessMask AND FILE_DELETE Then
							strDroits = strDroits & "Suppression" & " ; "
						End If
 
						If objACE.AccessMask AND FILE_READ_EA Then
							strDroits = strDroits & "Autorisations de lecture" & ";"
						End If
						objWorkBook.ActiveSheet.Cells(intRow, intCol).Value = strDroits
						If Err.Number <> 0 Then
							WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
							WScript.Quit
						End If
					End If	
				End If
			Next
 
		Else
			objWorkBook.ActiveSheet.Cells(intRow, testErreur).Interior.ColorIndex = COLOR_ERREUR
			If Err.Number <> 0 Then
				WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
				WScript.Quit
			End If
		End If
	End If
 
	' Libération des variables de la fonction
	Set objFolderSecuritySettings = Nothing
	Set intRetVal = Nothing
	Set intControlFlags = Nothing
	Set objSD = Nothing
	Set arrACEs = Nothing
	Set objACE = Nothing
End Sub 
''''''''''''''''''''''''''''''
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Action Principale
'
WScript.Echo "Ce programme liste les sous-dossiers d'un répertoire donné et leurs droits NTFS dans un fichier Excel"
 
strMessage = "Niveau de recherche : "
strTitle = "Niveau"
strPath = "2"
 
nivMax = InputBox(strMessage, strTitle, strPath)
nivMax = Trim(nivMax)
testIsANumber = false
 
 
If nivMax = "" Then
	WScript.Echo "fin du programme"
	WScript.Quit
End If
 
Do While (testIsANumber = false)	
	Essai = CInt(nivMax)
	If Err.Number = 0 Then
		If (Essai > 0) Then
			testIsANumber = true
			nivMax = Essai
		Else
			nivMax = InputBox("ERREUR : Entrer un nombre entier positif")
		End If
	Else
		nivMax = InputBox("ERREUR : Entrer un nombre entier positif")
		Err.Clear
	End If
Loop
 
 
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objWMIService = GetObject("winmgmts:")
 
strMessage = "Entrer le chemin du dossier :"
strTitle = "Chemin"
strPath = "C:\"
cheminFolder = InputBox(strMessage, strTitle, strPath)
cheminFolder = Trim(cheminFolder)
 
If cheminFolder = "" Then
	WScript.Echo "fin du programme"
	WScript.Quit
End If
 
If Right(cheminFolder, 1) <> "\" Then
	cheminFolder = cheminFolder + "\"
End If
'WScript.Echo "cheminFolder : " & cheminFolder
 
Set folder_base = objFso.GetFolder(cheminFolder)
'WScript.Echo "folder_base : " & folder_base
 
If Err.Number <> 0 Then
	WScript.Echo "ERREUR" & VbCrLf & "Le chemin que vous avez entré n'existe peut-être pas, ou vous n'avez peut-être pas les droits en lecture"
	WScript.Quit
End If
 
Set objExcel = CreateObject("Excel.Application")
 
If Err.Number <> 0 Then
	WScript.Echo "ERREUR : Impossible de lancer l'application Microsoft Excel"
	WScript.Quit
End If
 
objExcel.Visible = True
 
Set objWorkbook = objExcel.Workbooks.Add
 
If Err.Number <> 0 Then
	WScript.Echo "ERREUR : Impossible de créer un nouveau classeur dans Excel"
	WScript.Quit
End If
 
colonne_groupe = 1 + nivMax
colonneDebut = 2 + nivMax
 
objWorkBook.ActiveSheet.Cells(LIGNE_DEBUT - 2, 1).Value = "Dossiers : "
objWorkBook.ActiveSheet.Cells(LIGNE_DEBUT - 2, 1).Font.Bold = TRUE
objWorkBook.ActiveSheet.Cells(LIGNE_DEBUT - 2, 1).Borders.Weight = 2
objWorkBook.ActiveSheet.Cells(LIGNE_DEBUT - 2, 1).Borders.ColorIndex = 1
 
objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, colonne_groupe).Value = "Groupe ou User : "
objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, colonne_groupe).Font.Bold = TRUE
objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, colonne_groupe).Borders.Weight = 2
objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, colonne_groupe).Borders.ColorIndex = 1
 
If Err.Number <> 0 Then
	WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
	WScript.Quit
End If
 
intRow = LIGNE_DEBUT
 
Recup_sous_repertoires cheminFolder, 0 
 
j = colonneDebut 
 
Do While (objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, j).Value <> "" )
	objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, j).Borders.Weight = 2
	objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, j).Borders.ColorIndex = 1
	j = j + 1
Loop
 
For i = LIGNE_DEBUT To intRow - 1
	j = colonneDebut
 
	Do While (objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, j).Value <> "" )
		objWorkBook.ActiveSheet.Cells(i, j).Borders.Weight = 2
		objWorkBook.ActiveSheet.Cells(i, j).Borders.ColorIndex = 1
		j = j + 1
	Loop
Next
 
For i = LIGNE_DEBUT To intRow - 1
 
	For j = COLONNE_NIVEAU1 To nivMax
 
		If (objWorkBook.ActiveSheet.Cells(i, j).Value <> "") Then
			objWorkBook.ActiveSheet.Cells(i, j).Borders.Weight = 2
			objWorkBook.ActiveSheet.Cells(i, j).Borders.ColorIndex = 1
		End If
	Next
Next
 
intRow = intRow + 4
 
objWorkBook.ActiveSheet.Cells(intRow, 1).Value = "LEGENDE:"
 
objWorkBook.ActiveSheet.Cells(intRow, 1).Borders.Weight = 2
objWorkBook.ActiveSheet.Cells(intRow, 1).Borders.ColorIndex = 1
 
objWorkBook.ActiveSheet.Cells(intRow, 2).Value = "ECRITURE : "
objWorkBook.ActiveSheet.Cells(intRow, 3).Interior.ColorIndex = COLOR_ECRITURE
 
intRow = intRow + 1	
objWorkBook.ActiveSheet.Cells(intRow, 2).Value = "LECTURE : "
objWorkBook.ActiveSheet.Cells(intRow, 3).Interior.ColorIndex = COLOR_LECTURE
objWorkBook.ActiveSheet.Cells(intRow, 3).Interior.Pattern = xlLightDown
 
intRow = intRow + 1	
objWorkBook.ActiveSheet.Cells(intRow, 2).Value = "Particulier :"
objWorkBook.ActiveSheet.Cells(intRow, 3).Interior.ColorIndex = COLOR_PARTICULIER
 
intRow = intRow + 1	
objWorkBook.ActiveSheet.Cells(intRow, 2).Value = "ERREUR"
objWorkBook.ActiveSheet.Cells(intRow, 3).Interior.ColorIndex = COLOR_ERREUR
 
For i = intRow - 3 To intRow
 
	For j = 2 To 3 
		objWorkBook.ActiveSheet.Cells(i, j).Borders.Weight = 2
		objWorkBook.ActiveSheet.Cells(i, j).Borders.ColorIndex = 1
	Next
Next
 
i = colonneDebut
 
Do While (objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, i).Value <> "" )
	'WScript.Echo "Ajustement automatique de la colonne contenant la cellule " & "(1, " & i & ")"
	objWorkBook.ActiveSheet.Cells(1, i).Activate
	Set objRange = objExcel.ActiveCell.EntireColumn
	objRange.Autofit()
	i = i + 1
Loop
 
For i = COLONNE_NIVEAU1 To nivMax + 1
	'WScript.Echo "Ajustement automatique de la colonne contenant la cellule " & "(1, " & i & ")"
	objWorkBook.ActiveSheet.Cells(1, i).Activate
	Set objRange = objExcel.ActiveCell.EntireColumn
	objRange.Autofit()
Next
 
objWorkBook.ActiveSheet.Cells(1, 1).Value = "Droits NTFS des sous répertoires de " & folder_base
objWorkBook.ActiveSheet.Cells(1, 1).Font.Bold = TRUE
objWorkBook.ActiveSheet.Cells(1, 1).Font.Size = 14	
objWorkBook.ActiveSheet.Cells(1, 1).Font.ColorIndex = 3
 
Set objRange = objExcel.Range("A1")
objRange.Activate
Set objRange = objExcel.ActiveCell.EntireRow
objWorkBook.ActiveSheet.Cells(1, 1).RowHeight = 30
 
intRow = intRow + 4
 
objWorkBook.ActiveSheet.Cells(intRow, 1).Value = "Script : " & wscript.ScriptName
 
If Err.Number <> 0 Then
	WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
	WScript.Quit
End If
 
WScript.Echo "fin du programme"
 
WScript.Quit

Tu pense pouvoir m'aider??
Pourquoi Activesheet génèrerait des problèmes ??

Merci

**AlainTech** · 04/04/2007, 18h25

Envoyé par pitchalov

Pourquoi Activesheet génèrerait des problèmes ??

Parce que ActiveSheet est la feuille active.
Autrement dit, si tu ouvres un autre classeur, la feuille active est la feuille visible dans cet autre classeur.

**ThierryAIM** · 04/04/2007, 18h37

Envoyé par pitchalov

Pourquoi Activesheet génèrerait des problèmes ??

simple réflexion basique : Activesheet = la feuille active, donc si tu changes de feuille en cours de script... ??

Sinon, je comprends pas pourquoi tu fais exécuter ton script en visible ?

Edit: croisé avec Alain, j'avais ma réponse en attente, mais je regardais ton script

**omen999** · 04/04/2007, 20h09

bonsoir,

le problème est ailleurs
dans le précédent post, je pensais plutôt à quelque chose comme ça

Code :

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

1
2
3
4
5
6
7
8
9
10
11
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible=True
Set objWorkbook=objExcel.Workbooks.Add
 
Set objSheet=objWorkBook.ActiveSheet
'VARIANTE
'Set objSheet=objWorkBook.WorkSheets.Item(2) 
for x=1 to 500
objSheet.Cells(x,1).Value="voter pour moi"
next
msgbox "c'est fini"

pas de souci avec l'activesheet puisque l'objet objSheet est instancié une fois et n'est pas affecté par une manip ultérieure de l'utilisateur
j'ai testé ce code, il fonctionne parfaitement à la condition de basculer vers les autres feuilles du classeur avec le raccourci clavier

c'est l'utilisation de la souris qui fait planter le script...

la variante qui définit objSheet avec la deuxième feuille du classeur permet à un utilisateur de travailler sur la 1ère sans problème (à la condition de ne pas utiliser la souris)

**pitchalov** · 04/04/2007, 22h14

(à la condition de ne pas utiliser la souris)

Justement là est mon problème, je voudrais me servir de ma souris et éventuellement travailler avec excel pour faire autre chose

...

Y a-t-il sollution à mon problème?

Sinon, je comprends pas pourquoi tu fais exécuter ton script en visible

Bah en fait je trouvais ça pas mal que l'utilisateur puisse voir à tout moment que le script est bien toujours en train de mouliner...

Je me disais, est-ce qu'il y aurait un autre moyen de montrer que le script tourne bien et avance sans montrer la feuille excel?
(genre fenêtre non-blocante affichant le contenu d'une variable, ou alors image gif demandant de patienter...)
Vous sauriez copmment on peut faire ça? (toujours en vbs, bien sûr)

Merci

**ThierryAIM** · 05/04/2007, 10h34

Envoyé par pitchalov

Bah en fait je trouvais ça pas mal que l'utilisateur puisse voir à tout moment que le script est bien toujours en train de mouliner...

Petit test comparatif sur mon pc pour une recherche sur une profondeur de 1 :

Excel visible, screenupdating = true : 28 secondes
Excel caché, screenupdating = false : 13 secondes

au cas ou, pour empècher de changer de feuille avec la souris, tu peux n'ajouter qu'une seule feuille dans ton classeur :

Code :

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

1
2
objExcel.SheetsInNewWorkbook = 1
Set objWorkbook = objExcel.Workbooks.Add

sinon regarde ce que omen propose ici : http://www.developpez.net/forums/sho...d.php?t=220699

**omen999** · 05/04/2007, 11h44

sinon pour éviter le plantage du click souris, il reste l'ultime technique du scripteur désespéré...
ajouter juste avant le code d'alimentation des cellules l'instruction

Code :

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

on error resume next

testé sur mon exemple de code

**pitchalov** · 11/04/2007, 11h53

Merci pour votre aide et vos réponses.

Finalement je n'ai pas trouvé d'autre alternative que de bloquer excel avec interactive = false et de ne pas mettre à jour l'affichage avec screenupdating = false.

C'est la meilleure solution que j'ai trouvé, car la seule erreur qui peut être générée est lors de l'ouverture d'un autre fichier excel, mais elle est gérée avec On error resume next -> le scipt est arrêté et les propriétés d'excel sont rétablies.

Je vous poste mon code final (en entier):

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
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SCRIPT VBS PERMETTANT DE LISTER LES SOUS REPERTOIRES SUR n NIVEAUX
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Options
'
' Option : Toutes les variables et constantes doivent être définies
Option Explicit
 
' Option : Ne pas stopper le programme en cas d'erreur
On Error Resume Next
''''''''''''''''''''''''''''''
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Définition des constantes
'
Const SE_DACL_PRESENT = &h4
Const ACCESS_ALLOWED_ACE_TYPE = &h0
Const ACCESS_DENIED_ACE_TYPE  = &h1
 
Const FOLDER_ADD_SUBDIRECTORY = &h000004
Const FILE_DELETE             = &h010000
Const FOLDER_TRAVERSE         = &h000020
Const FILE_READ_ATTRIBUTES    = &h000080
Const FILE_READ_CONTROL       = &h020000
Const FOLDER_LIST_DIRECTORY   = &h000001
Const FILE_READ_EA            = &h000008
Const FILE_WRITE_EA           = &h000010
Const FILE_SYNCHRONIZE        = &h100000
Const FILE_WRITE_ATTRIBUTES   = &h000100
Const FILE_WRITE_DAC          = &h040000
Const FOLDER_ADD_FILE         = &h000002
 
Const COLOR_ERREUR = 16
Const COLOR_ECRITURE = 35
Const COLOR_LECTURE = 40
Const COLOR_PARTICULIER = 39
 
Const LIGNE_GROUPE = 3
Const LIGNE_DEBUT = 6
Const COLONNE_NIVEAU1 = 1
Const COLONNE_NIVEAU2 = 2
Const COLONNE_NIVEAU3 = 3
Const COLONNE_NIVEAU4 = 4
 
Const xlLightDown = 13
Const xlAutomatic = 0
''''''''''''''''''''''''''''''
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Définition des variables
'
Dim colonne_groupe
 
Dim objFso
Dim objWMIService
Dim objWshShell
Dim Excelfile
Dim strMessage
Dim strTitle
Dim strPath
Dim cheminFolder
Dim timeDebut
Dim timeFin
Dim folder_base
Dim tempsExecSec
Dim	tempsExecHour
Dim	tempsExecMin
Dim strDroits
Dim nbrGroup
Dim i, j
Dim testIsPresent
Dim objExcel
Dim objWorkbook
Dim objRange
Dim intRow
Dim	intCol
Dim testErreur
Dim nivMax
Dim testIsANumber
Dim retour
Dim colonneDebut
Dim cheminSave
Dim Essai
Dim strFolderName
''''''''''''''''''''''''''''''
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Fonction Quitter() : prend en paramètre le retour du programme
'
Sub Quitter(retour)
 
	If retour = 1 Then
		objExcel.Visible = True
		objExcel.Screenupdating = True
		objExcel.Interactive = True
	End If
 
	' Libération des variables
	Set colonne_groupe = Nothing
 
	Set objFso = Nothing
	Set objWMIService = Nothing
	Set objWshShell = Nothing
	Set Excelfile = Nothing
	Set strMessage = Nothing
	Set strTitle = Nothing
	Set strPath = Nothing
	Set cheminFolder = Nothing
	Set timeDebut = Nothing
	Set timeFin = Nothing
	Set folder_base = Nothing
	Set tempsExecSec = Nothing
	Set	tempsExecHour = Nothing
	Set	tempsExecMin = Nothing
	Set strDroits = Nothing
	Set nbrGroup = Nothing
	Set i = Nothing
	Set j = Nothing
	Set testIsPresent = Nothing
	Set objExcel = Nothing
	Set objWorkbook = Nothing
	Set objRange = Nothing
	Set intRow = Nothing
	Set	intCol = Nothing
	Set testErreur = Nothing
	Set nivMax = Nothing
	Set testIsANumber = Nothing
	Set colonneDebut = Nothing
	Set cheminSave = Nothing
	Set Essai = Nothing
	Set strFolderName = Nothing
 
	' Fin du programme - Le programme retourne la valeur de retour
	' Valeur 0 ==> Ok 
	'Valeur 1 ==> Erreur avec les saisies ou avec Excel 
	'Valeur 2 ==> Pas d'enregistrement
 
	WScript.Echo "FIN DU PROGRAMME"
	WScript.Quit retour
End Sub
''''''''''''''''''''''''''''''
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Fonction Recup_sous_repertoires() :  permet de récupérer tous les sous-répertoires de niveau nivMax du chemin passé en paramètre (chemin)
'
Sub Recup_sous_repertoires(chemin, niveau)
 
	' Option : Ne pas stopper le programme en cas d'erreur
	On Error Resume Next
 
	' Dédinition des variables de la fonction
	Dim rep
	Dim sousrep
	Dim folder
 
	'WScript.Echo "Entree dans le niveau " & niveau & " de la fonction Recup_sous_repertoires" 	
	'WScript.Echo "chemin : " & chemin
 
	Set rep = objFso.GetFolder(chemin)
	Set sousrep = rep.SubFolders
 
	' Recherche de tous les dossiers de niveau 1
	For Each folder in sousrep
 
		'WScript.Echo "folder name : " & folder.name
 
		strFolderName = folder.name
		If Err.Number <> 0 Then
			strFolderName = ""
			Err.Clear
		End If
 
 
		objWorkBook.ActiveSheet.Cells(intRow, COLONNE_NIVEAU1 + niveau).Value = strFolderName
 
		If Err.Number <> 0 Then
			WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
			Quitter 1 
		End If
 
		intCol = colonneDebut
		testErreur = COLONNE_NIVEAU1 + niveau
 
		Recup_Droits folder
 
		intRow = intRow + 1
 
		'WScript.Echo "nivMax = " & nivMax & " ; niveau = " & niveau
 
		If niveau < nivMax - 1 Then
			Recup_sous_repertoires folder, niveau + 1
		End If
	Next
	'WScript.Echo "Sortie du niveau " & niveau & " de la fonction Recup_sous_repertoires" 
 
	' Libération des variables
	Set rep = Nothing
	Set sousrep = Nothing
	Set folder = Nothing
End Sub
''''''''''''''''''''''''''''''
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Fonction Recup_Droits() : permet de récupérer les droits NTFS du dossier passé en paramètre (folder)
'
Sub Recup_Droits(folder)
 
	' Option : Ne pas stopper le programme en cas d'erreur
	On Error Resume Next
 
	' Dédinition des variables de la fonction
	Dim objFolderSecuritySettings
	Dim intRetVal
	Dim intControlFlags
	Dim objSD
	Dim arrACEs
	Dim objACE
 
	' Dans la chaîne folder, on remplace tous les '\' par "\\"
	folder = Replace(folder, "\", "\\")
 
	' Récupération des droits NTFS du dossier folder
	Set objFolderSecuritySettings = objWMIService.Get("Win32_LogicalFileSecuritySetting=""" & folder & """")
	'WScript.Echo "folder : " & folder
 
	If Err.Number <> 0 Then	
		'WScript.Echo "Erreur : Impossible d'obtenir les informations sur les droits NTFS du dossier " & folder & VbCrLf & VbCrLf & "Erreur n° " & Err.Number & " , Description : " & Err.Description
		'objWorkBook.ActiveSheet.Cells(intRow, 4).Value = "ERREUR"
		objWorkBook.ActiveSheet.Cells(intRow, testErreur).Interior.ColorIndex = COLOR_ERREUR
		'objWorkBook.ActiveSheet.Cells(intRow, 5).Value = "Erreur n° " & Err.Number
		'objWorkBook.ActiveSheet.Cells(intRow, 5).Interior.ColorIndex = COLOR_ERREUR
		'objWorkBook.ActiveSheet.Cells(intRow, 6).Value = " Description : " & Err.Description
		'objWorkBook.ActiveSheet.Cells(intRow, 6).Interior.ColorIndex = COLOR_ERREUR
		Err.Clear
 
	Else
		intRetVal = objFolderSecuritySettings.GetSecurityDescriptor(objSD)
 
		intControlFlags = objSD.ControlFlags
 
		If intControlFlags AND SE_DACL_PRESENT Then
			arrACEs = objSD.DACL
 
			For Each objACE in arrACEs
 
				If (objACE.Trustee.Name <> "Administrateurs") AND (objACE.Trustee.Name <> "SYSTEM") Then
					testIsPresent = false
					i = colonneDebut
 
					Do While (objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, i).Value <> "" )
 
						If (objACE.Trustee.Name = objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, i).Value) Then
							testIsPresent = true
							intCol = i
						End If
						i = i + 1
					Loop
 
					If testIsPresent = false Then
						intCol = i
						objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, intCol).Value = objACE.Trustee.Name
						'WScript.Echo "Nouveau groupe trouvé : " & objACE.Trustee.Name
 
						objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, intCol).Orientation = 90
						objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, intCol).Activate
						Set objRange = objExcel.ActiveCell.EntireColumn
						objRange.Autofit()
 
					End If
 
					If objACE.AccessMask AND FOLDER_TRAVERSE Then
 
						If objACE.AccessMask AND FILE_READ_ATTRIBUTES Then
 
							If objACE.AccessMask AND FILE_READ_EA Then
 
								If objACE.AccessMask AND FOLDER_LIST_DIRECTORY Then
 
									If objACE.AccessMask AND FILE_WRITE_EA Then
 
										If objACE.AccessMask AND FILE_DELETE Then
 
											If objACE.AccessMask AND FILE_WRITE_ATTRIBUTES Then
 
												If objACE.AccessMask AND FOLDER_ADD_FILE Then
													objWorkBook.ActiveSheet.Cells(intRow, intCol).Interior.ColorIndex = COLOR_ECRITURE
													objWorkBook.ActiveSheet.Cells(intRow, intCol).Value = ""
													If Err.Number <> 0 Then
														WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
														Quitter 1 
													End If
												End If
											End If
										End If
 
									Else
										objWorkBook.ActiveSheet.Cells(intRow, intCol).Interior.ColorIndex = COLOR_LECTURE
										objWorkBook.ActiveSheet.Cells(intRow, intCol).Interior.Pattern = xlLightDown
										objWorkBook.ActiveSheet.Cells(intRow, intCol).Value = ""
										If Err.Number <> 0 Then
											WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
											Quitter 1 
										End If
									End If
								End If
							End If
						End If
 
					Else
						objWorkBook.ActiveSheet.Cells(intRow, intCol).Interior.ColorIndex = COLOR_PARTICULIER
 
						strDroits = ""
 
						If objACE.AccessMask AND FOLDER_TRAVERSE Then
							strDroits = strDroits & "Parcours du dossier / exécuter le fichier" & " ; "
						End If
 
						If objACE.AccessMask AND FOLDER_LIST_DIRECTORY Then
							strDroits = strDroits & "Liste du dossier / lecture de données" & " ; "
						End If
 
						If objACE.AccessMask AND FILE_READ_ATTRIBUTES Then
							strDroits = strDroits & "Attributs de lecture" & " ; "
						End If
 
						If objACE.AccessMask AND FILE_WRITE_EA Then
							strDroits = strDroits &  "Création de fichiers / écriture de données" & " ; "
						End If
 
						If objACE.AccessMask AND FOLDER_ADD_FILE Then
							strDroits = strDroits & "Création de dossier / ajout de données" & " ; "
						End If	
 
						If objACE.AccessMask AND FILE_WRITE_ATTRIBUTES Then
							strDroits = strDroits & "Attributs d'écriture" & " ; "
						End If
 
						If objACE.AccessMask AND FILE_DELETE Then
							strDroits = strDroits & "Suppression" & " ; "
						End If
 
						If objACE.AccessMask AND FILE_READ_EA Then
							strDroits = strDroits & "Autorisations de lecture" & ";"
						End If
						objWorkBook.ActiveSheet.Cells(intRow, intCol).Value = strDroits
						If Err.Number <> 0 Then
							WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
							Quitter 1 
						End If
					End If	
				End If
			Next
 
		Else
			objWorkBook.ActiveSheet.Cells(intRow, testErreur).Interior.ColorIndex = COLOR_ERREUR
			If Err.Number <> 0 Then
				WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
				Quitter 1
			End If
		End If
	End If
 
	' Libération des variables de la fonction
	Set objFolderSecuritySettings = Nothing
	Set intRetVal = Nothing
	Set intControlFlags = Nothing
	Set objSD = Nothing
	Set arrACEs = Nothing
	Set objACE = Nothing
End Sub 
''''''''''''''''''''''''''''''
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Action Principale
'
Set objWshShell=Wscript.CreateObject("WScript.Shell")
 
WScript.Echo "Ce programme liste les sous-dossiers d'un répertoire donné et leurs droits NTFS dans un fichier Excel"
 
strMessage = "Niveau de recherche : "
strTitle = "Niveau"
strPath = "2"
 
nivMax = InputBox(strMessage, strTitle, strPath)
nivMax = Trim(nivMax)
testIsANumber = false
 
 
If nivMax = "" Then
	Quitter 1
End If
 
Do While (testIsANumber = false)	
	Essai = CInt(nivMax)
	If Err.Number = 0 Then
		If (Essai > 0) Then
			testIsANumber = true
			nivMax = Essai
		Else
			nivMax = InputBox("ERREUR : Entrer un nombre entier positif")
		End If
	Else
		nivMax = InputBox("ERREUR : Entrer un nombre entier positif")
		Err.Clear
	End If
Loop
 
 
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objWMIService = GetObject("winmgmts:")
 
strMessage = "Entrer le chemin du dossier :"
strTitle = "Chemin"
strPath = "C:\"
cheminFolder = InputBox(strMessage, strTitle, strPath)
cheminFolder = Trim(cheminFolder)
 
If cheminFolder = "" Then
	Quitter 1
End If
 
timeDebut = Second(Now) + 60*Minute(Now) + 3600*Hour(Now) + 86400*Day(Now)
 
If Right(cheminFolder, 1) <> "\" Then
	cheminFolder = cheminFolder + "\"
End If
'WScript.Echo "cheminFolder : " & cheminFolder
 
Set folder_base = objFso.GetFolder(cheminFolder)
'WScript.Echo "folder_base : " & folder_base
 
If Err.Number <> 0 Then
	WScript.Echo "ERREUR" & VbCrLf & "Le chemin que vous avez entré n'existe peut-être pas, ou vous n'avez peut-être pas les droits en lecture"
	Quitter 1
End If
 
Set objExcel = CreateObject("Excel.Application")
 
If Err.Number <> 0 Then
	WScript.Echo "ERREUR : Impossible de lancer l'application Microsoft Excel"
	Quitter 1
End If
 
Set objWorkbook = objExcel.Workbooks.Add
 
If Err.Number <> 0 Then
	WScript.Echo "ERREUR : Impossible de créer un nouveau classeur dans Excel"
	Quitter 1
End If
 
objExcel.Visible = True
 
colonne_groupe = 1 + nivMax
colonneDebut = 2 + nivMax
 
objWorkBook.ActiveSheet.Cells(LIGNE_DEBUT - 2, 1).Value = "Dossiers : "
objWorkBook.ActiveSheet.Cells(LIGNE_DEBUT - 2, 1).Font.Bold = TRUE
objWorkBook.ActiveSheet.Cells(LIGNE_DEBUT - 2, 1).Borders.Weight = 2
objWorkBook.ActiveSheet.Cells(LIGNE_DEBUT - 2, 1).Borders.ColorIndex = 1
 
objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, colonne_groupe).Value = "Groupe ou User : "
objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, colonne_groupe).Font.Bold = TRUE
objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, colonne_groupe).Borders.Weight = 2
objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, colonne_groupe).Borders.ColorIndex = 1
 
objWshShell.Popup "Veuillez patienter ..." & VBCRLF & "Le tableau va se remplir en arrière-plan", 2, "Droits DACL de " & folder_base, vbInformation
objExcel.Screenupdating = False
objExcel.Interactive = False
 
If Err.Number <> 0 Then
	WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
	Quitter(1)
End If
 
intRow = LIGNE_DEBUT
 
Recup_sous_repertoires cheminFolder, 0 
 
j = colonneDebut 
 
Do While (objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, j).Value <> "" )
	objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, j).Borders.Weight = 2
	objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, j).Borders.ColorIndex = 1
	j = j + 1
Loop
 
For i = LIGNE_DEBUT To intRow - 1
	j = colonneDebut
 
	Do While (objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, j).Value <> "" )
		objWorkBook.ActiveSheet.Cells(i, j).Borders.Weight = 2
		objWorkBook.ActiveSheet.Cells(i, j).Borders.ColorIndex = 1
		j = j + 1
	Loop
Next
 
For i = LIGNE_DEBUT To intRow - 1
 
	For j = COLONNE_NIVEAU1 To nivMax
 
		If (objWorkBook.ActiveSheet.Cells(i, j).Value <> "") Then
			objWorkBook.ActiveSheet.Cells(i, j).Borders.Weight = 2
			objWorkBook.ActiveSheet.Cells(i, j).Borders.ColorIndex = 1
		End If
	Next
Next
 
intRow = intRow + 4
 
objWorkBook.ActiveSheet.Cells(intRow, 1).Value = "LEGENDE:"
 
objWorkBook.ActiveSheet.Cells(intRow, 1).Borders.Weight = 2
objWorkBook.ActiveSheet.Cells(intRow, 1).Borders.ColorIndex = 1
 
objWorkBook.ActiveSheet.Cells(intRow, 2).Value = "ECRITURE : "
objWorkBook.ActiveSheet.Cells(intRow, 3).Interior.ColorIndex = COLOR_ECRITURE
 
intRow = intRow + 1	
objWorkBook.ActiveSheet.Cells(intRow, 2).Value = "LECTURE : "
objWorkBook.ActiveSheet.Cells(intRow, 3).Interior.ColorIndex = COLOR_LECTURE
objWorkBook.ActiveSheet.Cells(intRow, 3).Interior.Pattern = xlLightDown
 
intRow = intRow + 1	
objWorkBook.ActiveSheet.Cells(intRow, 2).Value = "Particulier :"
objWorkBook.ActiveSheet.Cells(intRow, 3).Interior.ColorIndex = COLOR_PARTICULIER
 
intRow = intRow + 1	
objWorkBook.ActiveSheet.Cells(intRow, 2).Value = "ERREUR"
objWorkBook.ActiveSheet.Cells(intRow, 3).Interior.ColorIndex = COLOR_ERREUR
 
For i = intRow - 3 To intRow
 
	For j = 2 To 3 
		objWorkBook.ActiveSheet.Cells(i, j).Borders.Weight = 2
		objWorkBook.ActiveSheet.Cells(i, j).Borders.ColorIndex = 1
	Next
Next
 
i = colonneDebut
 
Do While (objWorkBook.ActiveSheet.Cells(LIGNE_GROUPE, i).Value <> "" )
	'WScript.Echo "Ajustement automatique de la colonne contenant la cellule " & "(1, " & i & ")"
	objWorkBook.ActiveSheet.Cells(1, i).Activate
	Set objRange = objExcel.ActiveCell.EntireColumn
	objRange.Autofit()
	i = i + 1
Loop
 
For i = COLONNE_NIVEAU1 To nivMax + 1
	'WScript.Echo "Ajustement automatique de la colonne contenant la cellule " & "(1, " & i & ")"
	objWorkBook.ActiveSheet.Cells(1, i).Activate
	Set objRange = objExcel.ActiveCell.EntireColumn
	objRange.Autofit()
Next
 
objWorkBook.ActiveSheet.Cells(1, 1).Value = "Droits NTFS des sous répertoires de " & folder_base
objWorkBook.ActiveSheet.Cells(1, 1).Font.Bold = TRUE
objWorkBook.ActiveSheet.Cells(1, 1).Font.Size = 14	
objWorkBook.ActiveSheet.Cells(1, 1).Font.ColorIndex = 3
 
Set objRange = objExcel.Range("A1")
objRange.Activate
Set objRange = objExcel.ActiveCell.EntireRow
objWorkBook.ActiveSheet.Cells(1, 1).RowHeight = 30
 
intRow = intRow + 4
 
timeFin = Second(Now) + 60*Minute(Now) + 3600*Hour(Now) + 86400*Day(Now)
tempsExecSec = timeFin-timeDebut
tempsExecHour = Int(tempsExecSec/3600)
tempsExecSec = tempsExecSec - tempsExecHour*3600
tempsExecMin = Int(tempsExecSec/60)
tempsExecSec = tempsExecSec - tempsExecMin*60
 
objWorkBook.ActiveSheet.Cells(intRow, 1).Value = "Temps d'exécution : " & tempsExecHour&"H "&tempsExecMin&"min "&tempsExecSec&"sec"
intRow = intRow + 1
objWorkBook.ActiveSheet.Cells(intRow, 1).Value = "Script : " & wscript.ScriptName
 
objExcel.Visible = True
objExcel.Screenupdating = True
objExcel.Interactive = True
 
 
If Err.Number <> 0 Then
	WScript.Echo "ERREUR lors de l'écriture dans le fichier Excel"
	Quitter 1 
End If
 
 
' Enregistrement du fichier
strMessage = "Spécifiez le chemin dans lequel le fichier " & WScript.ScriptName & ".xls sera enregistré :"
strTitle = "Enregistrement"
strPath = "C:\"	
 
' Récupération du chemin
cheminSave = InputBox(strMessage, strTitle, strPath)
cheminSave = Trim(cheminSave)
 
' Si rien n'est entré, on ne sauvegarde pas et on quitte
If cheminSave = "" Then	
	WScript.Echo "Ce fichier n'a pas été enregistré"
	Quitter 2
End If
 
If Right(cheminSave, 1) <> "\" Then
	cheminSave = cheminSave + "\"
End If
 
objFso.GetFolder(cheminSave)
 
If Err.Number <> 0 Then
	WScript.Echo "Erreur" & VbCrLf & "Le chemin que vous avez rentré n'existe pas, ou vous n'avez pas les droits en lecture" & VbCrLf & VbCrLf & "Ce fichier n'a pas été enregistré"
	Quitter 2
End If
 
 
Excelfile = cheminSave & WScript.ScriptName & ".xls"
 
If objFso.FileExists(Excelfile) Then
	WScript.Echo "Le fichier " & Excelfile & " existe dèjà." & VbCrLf & "Il sera supprimé."
	objFso.DeleteFile(Excelfile)
 
	If Err.Number <> 0 Then
		WScript.Echo "Erreur : " & VbCrLf & VbCrLf & "Impossible de supprimer le fichier" & Excelfile & VbCrLf & "Vérifiez qu'il n'est pas déjà ouvert"	 & VbCrLf & VbCrLf & "Ce fichier n'a pas été enregistré"
		Quitter 2
	End If
 
	objWorkbook.SaveAs Excelfile
 
	If Err.Number <> 0 Then
		WScript.Echo "Impossible de créer le fichier : " & Excelfile & VbCrLf & VbCrLf & "Vous n'avez peut-être pas les droits en écriture" & VbCrLf & VbCrLf & "Ce fichier n'a pas été enregistré"
		'WScript.Echo "Description de l'erreur : " & Err.Description
		Quitter 2		
	End If
 
Else
	objWorkbook.SaveAs Excelfile
 
	If Err.Number <> 0 Then
		WScript.Echo "Impossible de créer le fichier : " & Excelfile & VbCrLf & VbCrLf & "Vous n'avez peut-être pas les droits en écriture" & VbCrLf & VbCrLf & "Ce fichier n'a pas été enregistré"
		'WScript.Echo "Description de l'erreur : " & Err.Description
		Quitter 2
	End If
End If
''''''''''''''''''''''''''''''
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Fin du programme
'
Quitter 0
''''''''''''''''''''''''''''''

Si vous trouvez une solution qui permettrait de ne pas bloquer excel et de ne pas générer d'erreur, n'hésitez pas.

Merci

à +

bloquer une seule page excel avec vbscript ?

VBScript

Discussions similaires

Partager

Partager