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
| Option Explicit
Option Base 1
Dim nomdossier As String
Dim Monclasseur As Variant
Dim nomclasseur As Variant
Dim recentDir As String
Dim h As Integer
Dim Tableau2()
'Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" ( _
ByVal lpBuffer As String, _
nSize As Long) As Long
Sub UserForm_Activate()
Dim Racine As String, var As String, nompc As String, x As Variant, finligne As Variant, fincolonne As Variant, nommacro As String
Dim modele, morpheeini, recherche5, recherche6, recherche7, recherche8, coordligne As Variant
'On Error GoTo error
var = "D:\Essais\COMMUN\panhard.gif"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
WebBrowser1.Navigate "ABOUT:<HTML><CENTER><HEAD><body scroll='no' LEFTMARGIN=0 TOPMARGIN=0><IMG " & " SRC='" & var & "'</IMG></BODY></CENTER></HTML>"
nompc = ComputerName
nompc = Right(nompc, 1)
'ouverture du fichier modele
morpheeini = "D:\Banc0" + nompc + "_Config\Morphee_panh0" + nompc + ".ini"
Workbooks.OpenText Filename:=morpheeini, Origin _
:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False _
, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 2), _
TrailingMinusNumbers:=True
coordligne = Cells.Find(What:="lasttest1", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Address
coordligne = Range(coordligne).Row
Rows("" + CStr(coordligne) + ":" + CStr(coordligne)).Select
Set recherche5 = Selection.Find(What:="Saint GOBAIN", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If recherche5 Is Nothing Then
Set recherche6 = Selection.Find(What:="MCO", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If recherche6 Is Nothing Then
Set recherche7 = Selection.Find(What:="DIESEL", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If recherche7 Is Nothing Then
Set recherche8 = Selection.Find(What:="ESSENCE", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If recherche8 Is Nothing Then
MsgBox "Aucun modele (Essence, diesel, Saint gobain et MCO) n'existe", vbCritical, "Erreur"
GoTo fin
Else
modele = "D:\Essais\COMMUN\Modele_ESSENCE.xls"
End If
Else
modele = "D:\Essais\COMMUN\Modele_DIESEL.xls"
End If
Else
modele = "D:\Essais\COMMUN\Modele_MCO.xls"
End If
Else
modele = "D:\Essais\COMMUN\Modele_saint_gobain.xls"
End If
If Dir(modele) = "" Then
MsgBox modele + " n'existe pas", vbCritical, "Erreur"
GoTo fin:
End If
ActiveWorkbook.Close
Workbooks.Open Filename:=modele
nommacro = ActiveWorkbook.Name
'recherche le repertoire le + récent
Racine = "D:\Banc0" + nompc + "_Donnees\donnees"
If Dir(Racine, vbDirectory) = "" Then
MsgBox Racine + " n'existe pas", vbCritical, "Erreur"
GoTo fin:
End If
ListeSousRepertoires Racine, True
recentDir = triDecroissant(Tableau2()) '
Erase Tableau2
h = 0
'Recherche le fichier T10 le plus récent
listeFichiers_dateModification recentDir
Workbooks.OpenText Filename:=triDecroissant2(Tableau2()), Origin:=xlMSDOS, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 4), Array(2, 1), Array(3, 1))
'Copie de la feuille de données brutes dans le fichier de dépouillement
Set Monclasseur = Application.ActiveWorkbook
nomclasseur = Monclasseur.Name
Selection.CurrentRegion.Select
Selection.Copy
Windows(nommacro).Activate
Sheets.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Windows(Monclasseur.Name).Activate
ActiveWorkbook.Close
'Copier coller des données brutes dans le tableaux de données traitées
Sheets("Données").Select
Range("A3").Select
Do While ActiveCell.Value <> ""
x = ActiveCell.Value
Sheets("Feuil1").Select
Range("A2").Select
Do While ActiveCell.Value <> ""
If ActiveCell.Value = x Then
Selection.Offset(1, 0).Select
If ActiveCell.Value <> "" Then
Range(Selection, Selection.End(xlDown)).Copy
Sheets("Données").Select
Selection.Offset(3, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Offset(-3, 0).Select
Sheets("Feuil1").Select
End If
Selection.Offset(-1, 0).Select
End If
Selection.Offset(0, 1).Select
Loop
Sheets("Données").Select
Selection.Offset(0, 1).Select
Loop
Sheets("Feuil1").Delete
Sheets("Données").Select
Range("A1").Select
'Chercher la coordonnée de ligne finale du tableau
finligne = Range("a6").End(xlDown).Address
finligne = Range(finligne).Row
'Chercher la coordonnée de colonne finale du tableau
fincolonne = Range("a3").End(xlToRight).Address
fincolonne = Range(fincolonne).Column
'Insertion des formules de calcul
'Calcul temps
Range("c6").Select
ActiveCell.Formula = "00:00:00"
Range("c7").Select
ActiveCell.Formula = "=c6+B7-B6"
Selection.AutoFill Destination:=Range("c7:c" + CStr(finligne))
'Mise en forme du tableau
Range(Cells(6, 1), Cells(finligne, fincolonne)).Select
With Selection.Font
.Name = "Arial Narrow"
.Size = 10
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("A1").Select
'Ouverture du fichier txt pour import de la cause de l'arrêt
Dim nomfichierT00 As String
Dim fichiertxt As Variant
nomfichierT00 = Left(Mid(nomdossier, 5), 2) + Left(Mid(nomdossier, 3), 2) + Left(Mid(nomdossier, 7), 2) + Right(nomdossier, 2) + ".Txt"
fichiertxt = "D:\Banc0" + nompc + "_Donnees\Donnees\" + nomdossier + "\" + nomfichierT00
If Dir(fichiertxt) = "" Then
MsgBox fichiertxt + " n'existe pas", vbCritical, "Erreur"
GoTo fin:
End If
Workbooks.OpenText Filename:=fichiertxt, Origin:= _
xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, _
4), Array(8, 1), Array(19, 1), Array(23, 1), Array(42, 1), Array(54, 1), Array(57, 1)), _
TrailingMinusNumbers:=True
Dim lignemini As String, lignearret As String, recherche1 As Variant, recherche2 As Variant
lignemini = Range("A1").End(xlDown).Row
Range(Cells(CStr(lignemini) - 5, 1), Cells(CStr(lignemini), 7)).Select
Set recherche1 = Selection.Find(What:="arret ", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If recherche1 Is Nothing Then
Set recherche2 = Selection.Find(What:="méthode", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If recherche2 Is Nothing Then
GoTo suite
Else
lignearret = Selection.Find(What:="méthode", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
End If
Else
lignearret = Selection.Find(What:="arret ", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
End If
Dim datearret As Date, heurearret As Date, causearret As String
datearret = Range("A" + CStr(lignearret)).Value
heurearret = Range("B" + CStr(lignearret)).Value
causearret = Range("G" + CStr(lignearret)).Value
suite:
ActiveWorkbook.Close
If causearret <> "" Then
Range("A1").Formula = causearret & Chr(10) & "Le " & datearret & " à " & heurearret
End If
'enregistrement automatique
Sheets("Données").Select
Range("A1").Select
ActiveWorkbook.SaveAs "D:\Banc0" + nompc + "_Donnees\Donnees\" + nomdossier + "\" + Left(nomclasseur, 8) + ".xls"
ActiveWindow.Close
'ouvrir dossier
Dim objshell As Shell
Set objshell = New Shell
objshell.explore ("D:\Banc0" + nompc + "_Donnees\Donnees\" + nomdossier)
Application.Quit
GoTo fin:
error:
MsgBox "Problème d'execution du code : voir le créateur du code !!!", vbCritical
MsgBox Err.Description, vbCritical, "ERREUR"
fin:
End Sub
Sub ListeSousRepertoires(SourceFolderName As String, _
IncludeSubfolders As Boolean) ' adapté de Ole P Erlandsen
Dim Fso As Object, SourceFolder As Object, SubFolder As Object
Dim RepItem As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(SourceFolderName)
h = h + 1
ReDim Preserve Tableau2(3, h)
Tableau2(1, h) = SourceFolder
Tableau2(2, h) = SourceFolder.DateLastModified
Tableau2(3, h) = SourceFolder.Name
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.subFolders
ListeSousRepertoires SubFolder.Path, IncludeSubfolders
Next SubFolder
End If
End Sub
Sub listeFichiers_dateModification(chemin As String)
Dim Fichier As String
Dim Fso As Object, FileItem As Object
Fichier = Dir(chemin & "\*.*")
Do
h = h + 1
ReDim Preserve Tableau2(3, h)
Set Fso = CreateObject("Scripting.FileSystemObject")
Set FileItem = Fso.GetFile(chemin & "\" & Fichier)
Tableau2(1, h) = FileItem
Tableau2(2, h) = FileItem.DateLastModified 'lastmodified
Tableau2(3, h) = FileItem.Type
Fichier = Dir
Loop Until Fichier = ""
End Sub
Function triDecroissant(Tableau()) As String
Dim i As Integer
Dim z As Byte, Valeur As Byte
Dim Cible As Variant
Do
Valeur = 0
For i = 1 To h - 1
If CDate(Tableau(2, i)) < CDate(Tableau(2, i + 1)) Then
For z = 1 To 3
Cible = Tableau(z, i)
Tableau(z, i) = Tableau(z, i + 1)
Tableau(z, i + 1) = Cible
Next z
Valeur = 1
End If
Next i
Loop While Valeur = 1
'--- le plus récent ---
nomdossier = Tableau(3, 1)
triDecroissant = Tableau(1, 1)
End Function
Function triDecroissant2(Tableau()) As String
Dim i As Integer
Dim z As Byte, Valeur As Byte
Dim Cible As Variant
Dim g As Integer
Dim chemin As String
Do
Valeur = 0
For i = 1 To h - 1
If CDate(Tableau(2, i)) > CDate(Tableau(2, i + 1)) Then
For z = 1 To 3
Cible = Tableau(z, i)
Tableau(z, i) = Tableau(z, i + 1)
Tableau(z, i + 1) = Cible
Next z
Valeur = 1
End If
Next i
Loop While Valeur = 1
'--- le plus récent de type T00 ---
For g = 1 To h
If Tableau(3, g) = "Fichier T00" Then
triDecroissant2 = Tableau(1, g)
Else
If Tableau(3, g) = "T00 File" Then
triDecroissant2 = Tableau(1, g)
End If
End If
Next g
If triDecroissant2 = "" Then
MsgBox "Aucun fichier de type T00 n'est present dans le dossier" + recentDir + "", vbCritical, "Erreur"
Exit Function
End If
End Function
Private Function ComputerName() As String
' Retourne le nom de l'ordinateur
Dim stTmp As String, lgTmp As Long
stTmp = Space$(250)
lgTmp = 251
Call GetComputerName(stTmp, lgTmp)
ComputerName = Split(stTmp, Chr$(0))(0)
End Function |
