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
| Option Explicit
Sub PopulateDirectoryList()
'dimension variables
Dim objFSO As FileSystemObject
Dim objFolder As Folder
Dim objFile As File
Dim strSourceFolder As String
Dim x As Long
Dim i As Long
Dim wbNew As Workbook
Dim wsNew As Worksheet
Dim intLen As Integer
Dim ChDate(6) As Date
Dim objFileDE As String
Dim objFileES As String
Dim objFileFR As String
Dim objFileNL As String
Dim objFilePT As String
Dim objFileRU As String
Dim FolderDE As String
Dim FolderES As String
Dim FolderFR As String
Dim FolderNL As String
Dim FolderPT As String
Dim FolderRU As String
Dim DocPathDE As String
Dim DocPathES As String
Dim DocPathFR As String
Dim DocPathNL As String
Dim DocPathPT As String
Dim DocPathRU As String
ToggleStuff False 'turn of screenupdating
Set objFSO = New FileSystemObject 'set a new object in memory
strSourceFolder = BrowseForFolder 'call up the browse for folder routine
'Set folders with the pathnames
FolderDE = "S:\SMP\Epos\Development\ettext\forms\VA\DE\"
FolderES = "S:\SMP\Epos\Development\ettext\forms\VA\ES\"
FolderFR = "S:\SMP\Epos\Development\ettext\forms\VA\FR\"
FolderNL = "S:\SMP\Epos\Development\ettext\forms\VA\NL\"
FolderPT = "S:\SMP\Epos\Development\ettext\forms\VA\PT\"
FolderRU = "S:\SMP\Epos\Development\ettext\forms\VA\RU\"
If strSourceFolder = "" Then Exit Sub
Workbooks.Add 'create a new workbook
Set wbNew = ActiveWorkbook
Set wsNew = wbNew.Sheets(1) 'set the worksheet
wsNew.Activate
'format a header
With wsNew.Range("A1:N1")
.Value = Array("GB", "Modified Date GB", "DE", "Modified Date DE", "ES", "Modified Date ES", "FR", _
"Modified Date FR", "NL", "Modified Date NL", "PT", "Modified Date PT", "RU", "Modified Date RU")
.Interior.ColorIndex = 15
.Font.Bold = True
.Font.Size = 10
End With
With Application.FileSearch
.LookIn = strSourceFolder 'look in the folder browsed to
.FileType = msoFileTypeAllFiles 'get all files
.SearchSubFolders = True 'search sub directories
.Execute 'run the search
For x = 1 To .FoundFiles.Count 'for each file found, by the count (or index)
i = x 'i is the rowcount
If x > 60000 Then 'if there happens to be more than multipls of 60,000 files, then add a new sheet
i = x - 60000 'set i to the right number for row placement below
Set wsNew = wbNew.Sheets.Add(after:=Sheets(wsNew.Index))
With wsNew.Range("A1:B1")
.Value = Array("File", "Modified Date")
.Interior.ColorIndex = 15
.Font.Bold = True
.Font.Size = 10
End With
End If
On Error GoTo Skip
Set objFile = objFSO.GetFile(.FoundFiles(x)) 'set the object to get it's properties
With wsNew.Cells(1, 1) 'populate the next row with the variable data
.Offset(i, 0) = objFile.Name
.Offset(i, 1) = objFile.DateLastModified
End With
'Change filename withe the right Language
intLen = Len(objFile.Name)
intLen = intLen - 6
objFileDE = (Left(objFile.Name, intLen) & "DE.doc")
objFileES = (Left(objFile.Name, intLen) & "ES.doc")
objFileFR = (Left(objFile.Name, intLen) & "FR.doc")
objFileNL = (Left(objFile.Name, intLen) & "NL.doc")
objFilePT = (Left(objFile.Name, intLen) & "PT.doc")
objFileRU = (Left(objFile.Name, intLen) & "RU.doc")
'Folderpath and filename are merged
DocPathDE = FolderDE & objFileDE
DocPathES = FolderES & objFileES
DocPathFR = FolderFR & objFileFR
DocPathNL = FolderNL & objFileNL
DocPathPT = FolderPT & objFilePT
DocPathRU = FolderRU & objFileRU
'If the file exists then fill the cells with the
'Filename and the change date
If FileOrDirExists(DocPathDE) Then
ChDate(1) = FileSystem.FileDateTime(DocPathDE)
With wsNew.Cells(1, 1)
.Offset(i, 2) = objFileDE
.Offset(i, 3) = ChDate(1)
If ChDate(1) < objFile.DateLastModified Then
Cells(i + 1, 4).Interior.ColorIndex = 6
End If
End With
End If
If FileOrDirExists(DocPathES) Then
ChDate(2) = FileSystem.FileDateTime(DocPathES)
With wsNew.Cells(1, 1)
.Offset(i, 4) = objFileES
.Offset(i, 5) = ChDate(2)
End With
If ChDate(2) < objFile.DateLastModified Then
Cells(i + 1, 6).Interior.ColorIndex = 6
End If
End If
If FileOrDirExists(DocPathFR) Then
ChDate(3) = FileSystem.FileDateTime(DocPathFR)
With wsNew.Cells(1, 1)
.Offset(i, 6) = objFileFR
.Offset(i, 7) = ChDate(3)
End With
If ChDate(3) < objFile.DateLastModified Then
Cells(i + 1, 8).Interior.ColorIndex = 6
End If
End If
If FileOrDirExists(DocPathNL) Then
ChDate(4) = FileSystem.FileDateTime(DocPathNL)
With wsNew.Cells(1, 1)
.Offset(i, 8) = objFileNL
.Offset(i, 9) = ChDate(4)
End With
If ChDate(4) < objFile.DateLastModified Then
Cells(i + 1, 10).Interior.ColorIndex = 6
End If
End If
If FileOrDirExists(DocPathPT) Then
ChDate(5) = FileSystem.FileDateTime(DocPathPT)
With wsNew.Cells(1, 1)
.Offset(i, 10) = objFilePT
.Offset(i, 11) = ChDate(5)
End With
If ChDate(5) < objFile.DateLastModified Then
Cells(i + 1, 12).Interior.ColorIndex = 6
End If
End If
If FileOrDirExists(DocPathRU) Then
ChDate(6) = FileSystem.FileDateTime(DocPathRU)
With wsNew.Cells(1, 1)
.Offset(i, 12) = objFileRU
.Offset(i, 13) = ChDate(6)
End With
If ChDate(6) < objFile.DateLastModified Then
Cells(i + 1, 14).Interior.ColorIndex = 6
End If
End If
On Error GoTo Skip
Skip:
'this is in case a Permission denied error comes up or an unforeseen error
'Do nothing, just go to next file
Next x
'Autofit the Columns
wsNew.Columns("A:N").AutoFit
'Fill the Cell red if it is empty
Range("A2:N2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="="""""
Selection.FormatConditions(1).Interior.ColorIndex = 3
End With
'clear the variables
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Set wsNew = Nothing
Set wbNew = Nothing
ToggleStuff True 'turn events back on
End Sub
Sub ToggleStuff(ByVal x As Boolean)
Application.ScreenUpdating = x
Application.EnableEvents = x
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
ToggleStuff True
End Function
Function FileOrDirExists(PathName As String) As Boolean
Dim iTemp As Integer
'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)
'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select
'Resume error checking
On Error GoTo 0
End Function |
:strip_icc():strip_exif()/u/253746/images1.jpg?f=community)
/u/28468/librarian2.png?f=community)
)
Dan zal ik mijn (voor)oordelen over goto en over 'exit function' achterwege laten 