特定のファイル名、フォルダ名、拡張子の除外

あるフォルダにあるファイルをエクセルのシートに表示するプログラムを作成しています。その際にファイル名、フォルダ名共にtmp、temp、bk、bak、$、コピー、の文字列を含むものを除外、そして拡張子はtmpのみを除外したいのですが現在のプログラムでは拡張子がtmp、temp、bk、bak、$、コピーものも除外されてしまいます。どのようにコードを記述すれば拡張子tmpのみを除外できるか全くわからないので質問させていただきました。当方プログラミングが初心者なこともあり、できればプログラムのコードも詳しくご教授していただければと思っております。申し訳ございませんが有識者の方、よろしくお願いします。

補足:このプログラムはfilesystemobjectを使用しております。

vba
1ここのコードでファイル、フォルダ、拡張子の除外を実装しています。
2
3Function ExceptionPartOfFoldersAndFiles(ByVal strFileName As String, ByVal strFolderName As String, ByVal strExtension As String) As Boolean
4
5    Dim varName As Variant
6
7    Dim varNames As Variant
8
9    ExceptionPartOfFoldersAndFiles = True
10
11    varNames = Array("tmp", "temp", "bk", "bak", "~$", "　ー　コピー")       '対象の文字列があれば除外
12
13    For Each varName In varNames
14
15        If InStr(LCase(strFileName), LCase(varName)) > 0 Then
16
17            Exit Function
18
19        ElseIf InStr(LCase(strFolderName), LCase(varName)) > 0 Then
20
21            Exit Function
22
23        ElseIf InStr(LCase(strExtension), LCase(varName)) > 0 Then
24
25            Exit Function
26
27        End If
28
29    Next
30
31    ExceptionPartOfFoldersAndFiles = False
32
33End Function

vba
1ソースコードの全文はこちらになります。
2
3Option Explicit
4
5Sub FileListOutput()
6
7    Dim lngInitiationSite As Long
8
9    Dim strPath As String
10
11    Dim ws As Worksheet
12
13   
14
15    Application.Cursor = xlWait
16
17    Application.ScreenUpdating = False
18
19   
20
21    lngInitiationSite = 7 'ファイル一覧開始行
22
23   
24
25    strPath = Worksheets("保管場所").Range("B3").Value 'ファイルパス取得
26
27   
28
29    Sheets("ファイル一覧").Select 'ファイル一覧シート選択
30
31   
32
33    Set ws = WorksheetSelect()
34
35    Range(Range("A7"), Range("A" & Cells.Rows.Count)).EntireRow.Delete '７行目以降消去
36
37   
38
39    Call FileDataAcquisition(strPath, lngInitiationSite) 'プロシージャの呼び出し
40
41    Call AscendingOrderSort
42
43    Call SerialNumber
44
45    Call SheetStyle
46
47 
48
49    Set ws = Nothing
50
51   
52
53    Application.ScreenUpdating = True
54
55    Application.Cursor = xlDefault
56
57End Sub
58
59 
60
61Sub FileDataAcquisition(strPath As String, lngInitiationSite As Long)
62
63    Dim lngRow As Long
64
65    Dim varTitle As Variant
66
67    Dim vartitles As Variant
68
69    Dim objFSO As Object, objFile As Object, objSubFolder
70
71    Dim varSearchFolder As Variant
72
73    Dim varGetFolder As Variant
74
75    Dim ws As Worksheet
76
77   
78
79    Set ws = WorksheetSelect()
80
81   
82
83    Range("A1") = "ＸＸフォルダ文書一覧"
84
85   
86
87    vartitles = Array("No.", "文書名", "作成日", "更新日", "コメント", "ファイル名＆リンク", "フォルダ")  '見出しの挿入
88
89    lngRow = 1
90
91    For Each varTitle In vartitles
92
93        ws.Cells(6, lngRow) = varTitle
94
95        lngRow = lngRow + 1
96
97    Next
98
99   
100
101    Set objFSO = CreateObject("Scripting.FileSystemObject")    'インスタンスの作成
102
103   
104
105    For Each objFile In objFSO.GetFolder(strPath).Files
106
107        varSearchFolder = InStrRev(objFile.Path, "\") 'ファイルパスを\マークごとに区切る
108
109        varGetFolder = Left(objFile.Path, varSearchFolder - 1) 'フォルダパスを抽出
110
111        If ExceptionPartOfFoldersAndFiles(objFile.Name, varGetFolder, objFSO.GetExtensionName(objFile.Path)) = False Then '対象の文字列を含むものを除外
112
113            ws.Cells(lngInitiationSite, 2) = objFSO.GetBaseName(objFile.Path)    '拡張子なしのファイル名
114
115            ws.Cells(lngInitiationSite, 3) = objFile.DateCreated    'ファイル作成日
116
117            ws.Cells(lngInitiationSite, 4) = objFile.DateLastModified    'ファイル更新日
118
119            ws.Cells(lngInitiationSite, 5) = CommentAcquisition(strPath, objFile.Name)    'コメント
120
121            ws.Hyperlinks.Add Anchor:=Cells(lngInitiationSite, 6), Address:=objFile.Path, TextToDisplay:=objFile.Name    'ファイル名ハイパーリンク
122
123            ws.Hyperlinks.Add Anchor:=Cells(lngInitiationSite, 7), Address:=strPath, TextToDisplay:=varGetFolder   'フォルダ名ハイパーリンク
124
125            lngInitiationSite = lngInitiationSite + 1
126
127        End If
128
129    Next
130
131   
132
133    For Each objSubFolder In objFSO.GetFolder(strPath).SubFolders 'サブフォルダからファイルの呼び出し
134
135        Call FileDataAcquisition(objSubFolder.Path, lngInitiationSite)
136
137    Next
138
139   
140
141    Set objFSO = Nothing
142
143    Set objSubFolder = Nothing
144
145    Set objFile = Nothing
146
147    Set ws = Nothing
148
149End Sub
150
151 
152
153Private Sub SerialNumber()
154
155    Dim lngListLastRowAcquisition As Long
156
157    Dim i As Long
158
159    Dim lngNumber As Long
160
161    Dim ws As Worksheet
162
163   
164
165    lngNumber = 1
166
167    Set ws = WorksheetSelect()
168
169   
170
171    lngListLastRowAcquisition = ws.Range("B7").End(xlDown).Row 'B7から最終行まで取得
172
173   
174
175    For i = 7 To lngListLastRowAcquisition 'B7セルから連番挿入
176
177        Cells(i, 1) = lngNumber
178
179        lngNumber = lngNumber + 1
180
181    Next
182
183   
184
185    Set ws = Nothing
186
187End Sub
188
189 
190
191Private Sub AscendingOrderSort()
192
193    '昇順ソート範囲を選択、第一キーに文書名、第二キーにフォルダを選択
194
195    Range("A6").CurrentRegion.Sort _
196
197    key1:=Range("B6"), _
198
199    Order1:=xlAscending, _
200
201    key2:=Range("G6"), _
202
203    Order2:=xlAscending, _
204
205    Header:=xlYes
206
207End Sub
208
209 
210
211Private Sub SheetStyle()       'シートのスタイルのプロシージャ
212
213    Dim ws As Worksheet
214
215 
216
217    Set ws = WorksheetSelect()
218
219 
220
221    Range("E1") = Now
222
223 
224
225    With ws.Range("A1").Font         'A1の文字を太字、サイズ20に変更
226
227        .Bold = True
228
229        .Size = 20
230
231        .Name = "游ゴシック Light"
232
233    End With
234
235 
236
237    With ws.Range("A6:G6")            'A2からG2を太字、真ん中、背景色を設定
238
239        .Font.Bold = True
240
241        .HorizontalAlignment = xlCenter
242
243        .Name = "游ゴシック"
244
245        .Interior.Color = RGB(217, 225, 242)
246
247    End With
248
249 
250
251    Set ws = Nothing
252
253End Sub
254
255 
256
257Function CommentAcquisition(ByVal strPath As String, ByVal strFileName As String)
258
259    Dim objShell As Object
260
261    Dim objFolder As Object
262
263    Set objShell = CreateObject("Shell.Application")    'シェルアプリケーションの作成
264
265    Set objFolder = objShell.Namespace(strPath & "\")     'ファイルオブジェクト作成、オブジェクトに収納
266
267    CommentAcquisition = objFolder.GetDetailsOf(objFolder.ParseName(strFileName), 24)     'ファイルプロパティのコメント取得
268
269    Set objFolder = Nothing
270
271    Set objShell = Nothing
272
273End Function
274
275 
276
277Function ExceptionPartOfFoldersAndFiles(ByVal strFileName As String, ByVal strFolderName As String, ByVal strExtension As String) As Boolean
278
279    Dim varName As Variant
280
281    Dim varNames As Variant
282
283    ExceptionPartOfFoldersAndFiles = True
284
285    varNames = Array("tmp", "temp", "bk", "bak", "~$", "　ー　コピー")       '対象の文字列があれば除外
286
287    For Each varName In varNames
288
289        If InStr(LCase(strFileName), LCase(varName)) > 0 Then
290
291            Exit Function
292
293        ElseIf InStr(LCase(strFolderName), LCase(varName)) > 0 Then
294
295            Exit Function
296
297        ElseIf InStr(LCase(strExtension), LCase(varName)) > 0 Then
298
299            Exit Function
300
301        End If
302
303    Next
304
305    ExceptionPartOfFoldersAndFiles = False
306
307End Function
308
309 
310
311Function WorksheetSelect() As Worksheet
312
313    Dim ws As Worksheet
314
315    Set ws = Worksheets("ファイル一覧")
316
317    Set WorksheetSelect = ws
318
319End Function