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
| Option Explicit
Public strPathJob As String
Dim strValue As String
Private Sub ButAdd_Click()
strValue = InputBox("Please enter a value to consider to translate the package", "Add filter")
If strValue = "NULL" Or strValue = "" Then
MsgBox "You must enter a not empty value!", vbCritical, "!STOP!"
Else
ListBoxFilters.AddItem UCase(strValue)
ButGenerate.Visible = True
End If
'Programs Descriptions ---------------------------------------------
Dim DataString(11) As String
Dim InString()
Dim i As Integer
'Remplissage du tableau qui va être testé
DataString(0) = "R" ' AC_WBY_A300
DataString(1) = "L" ' AC_SA_A318
DataString(2) = "L" ' AC_SA_A319
DataString(3) = "L" ' AC_SA_A319CJ
DataString(4) = "L" ' AC_SA_A320
DataString(5) = "L" 'AC_SA_A321
DataString(6) = "N" ' AC_LR_A330
DataString(7) = "N" ' AC_LR_A340
DataString(8) = "F" ' AC_LR_A380
DataString(9) = "N" ' AC_XWB_A350
DataString(10) = "M" ' AC_Military_A400M
DataString(11) = ";"
'"DataString" est le tableau dans lequel doit être effectué la recherche.
'"str" est la chaîne à rechercher.
'La fonction Filter renvoie le tableau "InString" contenant les éléments
'qui répondent aux critères de la recherche.
i = i + 1
ReDim Preserve InString(i)
InString(i) = Filter(DataString, strValue, True, vbTextCompare)
'Boucle sur le tableau afin de visualiser les éléments
'qui répondent aux critères de recherche.
For i = 0 To UBound(InString)
Debug.Print InString(i)
Next i
End Sub
Private Sub ButGenerate_Click()
'Return information success -----------------------------------------------------------------------------
MsgBox "All files has been processed.", vbExclamation, "Congratulation!"
End Sub
Private Sub ButBrowse_Click()
'Récupération du chemin de travail
strPathJob = SelectFolder("Sélectionnez un répertoire :", 0)
If strPathJob <> "" Then
' Permet de modifier la valeur Text du champ de texte.
TxtJobDirectory.Text = strPathJob 'indique le chemin complet
TxtJobDirectory.BackColor = &H80000005 'change la couleur du label
ButBrowse.Visible = True
ListFilesInFolder strPathJob, True
Else
MsgBox "Please select a job directory only which contain all CATIA files!", vbCritical, "!STOP!"
End If
Exit Sub
End Sub
Private Sub ButExit_Click()
Unload Me
End
End Sub
' Lister les fichiers dans un tableau ----------------------------------------------------------------------------------
Sub ListFilesInFolder(strFolderName As String, bIncludeSubfolders As Boolean)
' adapté de Ole P Erlandsen
' necessite d'activer la reference Microsoft Scripting RunTime
Dim FSO As FileSystemObject
Dim oSourceFolder As Scripting.Folder
Dim oSubFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim wksDest As Worksheet
Dim iRow As Long
Set wksDest = Worksheets(2)
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oSourceFolder = FSO.GetFolder(strFolderName)
wksDest.Cells(1, 1) = "Parent folder"
wksDest.Cells(1, 2) = "Full path"
wksDest.Cells(1, 3) = "File name"
wksDest.Cells(1, 4) = "Size"
wksDest.Cells(1, 5) = "Type"
wksDest.Cells(1, 6) = "Date created"
wksDest.Cells(1, 7) = "Date last modified"
wksDest.Cells(1, 8) = "Date last accessed"
wksDest.Cells(1, 9) = "Attributes"
wksDest.Cells(1, 10) = "Short path"
wksDest.Cells(1, 11) = "Short name"
iRow = 2
For Each oFile In oSourceFolder.Files
wksDest.Cells(iRow, 1) = oFile.ParentFolder.Path
wksDest.Cells(iRow, 2) = oFile.Path
wksDest.Cells(iRow, 3) = oFile.Name
wksDest.Cells(iRow, 4) = oFile.Size
wksDest.Cells(iRow, 5) = oFile.Type
wksDest.Cells(iRow, 6) = oFile.DateCreated
wksDest.Cells(iRow, 7) = oFile.DateLastModified
wksDest.Cells(iRow, 8) = oFile.DateLastAccessed
wksDest.Cells(iRow, 9) = oFile.Attributes
wksDest.Cells(iRow, 10) = oFile.ShortPath
wksDest.Cells(iRow, 11) = oFile.ShortName
iRow = iRow + 1
Next oFile
For Each oSubFolder In oSourceFolder.SubFolders
' On peut mettre ici un traitement spécifique pour les dossiers
Next oSubFolder
If bIncludeSubfolders Then
For Each oSubFolder In oSourceFolder.SubFolders
ListFilesInFolder oSubFolder.Path, True
Next oSubFolder
End If
End Sub
Private Sub ButFilesDir_Click()
If TxtJobDirectory.Text = "C:\createxdubernet\" Or TxtJobDirectory.Text = "" Then
MsgBox "Please select a job directory before!", vbCritical, "!STOP!"
Else
Sheets("Work files").Select
End If
Application.Wait Now + TimeValue("00:00:03")
Sheets("Reference File GENERATOR").Select
End Sub
Private Sub ButRemoved_Click()
If ListBoxFilters.ListCount = 0 Then
MsgBox "Please your filterlist is empty, add an item before use removed button", vbInformation, "Manager List"
Else
If ListBoxFilters.Object = "NULL" Or ListBoxFilters.Object = "" Or ListBoxFilters.ListIndex = -1 Then
MsgBox "Please select an item to delete", vbInformation, "Manager List"
Else
ListBoxFilters.RemoveItem (ListBoxFilters.ListIndex)
End If
If ListBoxFilters.ListCount = 0 Then
ButGenerate.Visible = False
Else
End If
End If
End Sub
Private Sub ButClearList_Click()
ListBoxFilters.Clear
End Sub |
[EXCEL] Validation des données saisies - nouvelle Question :-)
)
Répondre avec citation
A pas trouvé le lecteur 
Y'a un blème... Chez HTML ou chez moi ? 
soignez indulgent please ...
du tout ...
.... 
Envoyé par Tu
Partager