|
|
| [ＶＢ＆ＶＢＡ][FSO 指定ルートの配下全て(深階層まで)のファルダパスとフォルダ名取得(深階層まで)] |
Option Explicit
'**************************************************
'配下全てのThumbs.dbを削除するサンプル例
'**************************************************
Private lngRootCnt As Long
Private objFSO As Object
Private GetFileName As String '*処理
Private lngCnt As Long '*処理
Private Sub MakeSubFolderList()
'**************************************************
'指定ルートの配下全てのファルダパスとフォルダ名取得
'**************************************************
GetFileName = "Thumbs.db" '検索するファイル名'*処理
Dim strStartRoot As String
Set objFSO = New FileSystemObject
strStartRoot = ThisWorkbook.Path
lngRootCnt = 1
'再帰処理の為、サブルーチンをコールします
Call SubFolderSearch(strStartRoot)
Set objFSO = Nothing
End Sub
Private Sub SubFolderSearch(StartFolderPath As String)
'**************************************************
'フォルダパス及びフォルダ名取得再帰処理
'**************************************************
'無限ループ処理の為、フォルダやファイルの削除など行う場合は
'必ずバックアップを行って下さい。
'追加処理をした場合ＰＣのハングアップの危険もあります。
'一応動作確認は行ってます。
Dim SearchMainFolder As Folder
Dim SearchSubFolderA As Folder
Dim SearchSubFolderB As Folder
Dim objFolder As Object '*処理
Dim objFile As Object '*処理
Dim strFilePath As String '*処理
Dim strFileName As String '*処理
'*処理---------------------------------------------------------------/
'フォルダ直下
With objFSO
Set objFolder = .GetFolder(StartFolderPath)
For Each objFile In objFolder.Files
strFilePath = objFile.Path
strFileName = .GetFileName(strFilePath)
If InStr(1, strFileName, GetFileName) <> 0 Then
If MsgBox(strFilePath & vbNewLine & "Delete?", vbOKCancel, strFileName) = vbOK Then
lngCnt = lngCnt + 1 '処理数
'[Kill]関数では"Thumbs.db"等の特殊ファイルは削除不可
.GetFile(strFilePath).Delete
End If
End If
Next
Set objFolder = Nothing
End With
'*処理---------------------------------------------------------------/
'フォルダ数
lngRootCnt = lngRootCnt + 1
With objFSO
Set SearchMainFolder = .GetFolder(StartFolderPath)
For Each SearchSubFolderA In SearchMainFolder.SubFolders
'*処理---------------------------------------------------------------/
'フォルダ直下
Set objFolder = .GetFolder(SearchSubFolderA)
For Each objFile In objFolder.Files
strFilePath = objFile.Path
strFileName = .GetFileName(strFilePath)
If InStr(1, strFileName, GetFileName) <> 0 Then
If MsgBox(strFilePath & vbNewLine & "Delete?", vbOKCancel, strFileName) = vbOK Then
lngCnt = lngCnt + 1 '処理数
'[Kill]関数では"Thumbs.db"等の特殊ファイルは削除不可
.GetFile(strFilePath).Delete
End If
End If
Next
Set objFolder = Nothing
'*処理---------------------------------------------------------------/
'フォルダ数
lngRootCnt = lngRootCnt + 1
If SearchSubFolderA.SubFolders.Count > 0 Then
For Each SearchSubFolderB In SearchSubFolderA.SubFolders
Call SubFolderSearch(SearchSubFolderB.Path)
Next SearchSubFolderB
End If
Next SearchSubFolderA
End With
Set SearchMainFolder = Nothing
Set SearchSubFolderA = Nothing
Set SearchSubFolderB = Nothing
End Sub
Sub SetScrrunDLL()
'*****************************************************
'このコードが実装されたブックが「FileSystemObject」
'が使えるように参照設定をする。
'*****************************************************
On Error GoTo MyERROE:
'参照設定
ThisWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\system32\scrrun.dll"
MyERROE:
End Sub
|
|
|
