[[20150401123111]]　『EXCEL2007での FileSearch 問題』（疑問者）　ページの最後に飛ぶ

『EXCEL2007での FileSearch 問題』（疑問者）

すみません。

  EXCEL2003で動いていた下記VBAマクロ（関係部抜粋）ですが，excel2007になったら
全く動かなくなりました。
   原因は下記のFileSearchという命令がexcel2007では無くなってしまったことが
原因とわかりました。
   しかし，VBAに暗いので，これをEXCEL2007で使えるようにする方法がわかりません。
 下記のコードの部分が直せれば直して置き換えたいのですが
だれか置き換えるコードをご存知でしょうか。
       dirname， Filename2  は変数であり，この変数の条件に合うホルダ付ファイルを
セルに拾い出すマクロの一部です。

 -------------------------------------

 With Application.FileSearch
  .NewSearch
  .LookIn = dirname
  .SearchSubFolders = True
  .Filename = Filename2
  .MatchTextExactly = False '文字を一部に含むものを検索 完全一致でない
  .FileType = msoFileTypeAllFiles

  If .Execute() > 0 Then
  MsgBox .foundfile.Count & _
  "個のファイルが見つかりました。"
  Cells(3, 2) = .FoundFiles.Count
  For i = 1 To .FoundFiles.Count
  Cells(rowlast + i, 3) = .FoundFiles(i)

   next i
 ------------------------------

＜使用 Excel：Excel2007、使用 OS：unknown ＞

 こんな感じですか？
    Sub ファイル検索()
        Dim DirName   As String
        Dim FileName2 As String
        Dim FSO       As Object
        Dim F         As Variant
        Dim dic       As Object
        DirName = "C:\エクセルの学校"
        FileName2 = "テスト"
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set dic = CreateObject("Scripting.Dictionary")
        With FSO
            For Each F In .GetFolder(DirName).Files
                If F.Name Like "*" & FileName2 & "*" Then
                    dic.Add F.Name, ""
                End If
            Next F
        End With

        If dic.Count > 0 Then
            MsgBox dic.Count & "個のファイルが見つかりました"
            Cells(3, "B").Value = dic.Count
            Cells(Rows.Count, "C").End(xlUp).Offset(1).Resize(dic.Count).Value = Application.Transpose(dic.keys)
        End If
    End Sub

（稲葉） 2015/04/01(水) 13:00

稲葉さんありがとうございました。

          コードを置き換えて組んだところ，一応表示できましたが，今までと違い
          ファイル名しか表示されませんでしたので，
           ホルダ名を頭に付けたいのですが。 どう訂正すればよろしいのでしょうか。
                   （疑問者）

 フォルダ名は指定しているのだからいらない気がしますが、Nameプロパティの代わりにPathプロパティ
 使えばいいと思います！
 dic.Add F.Name, ""
          ~~~~~
 この部分
（稲葉） 2015/04/01(水) 13:35

 稲葉さん  上記で希望通りできたと思ったのですが
          今気づいたのですがサブホルダー内までは検索できませんでした。
           サブホルダーまでは無理でしょうか。

           （疑問者）

 すいません、回答じゃないのですがコメントする時はコメント欄から書いてください。
（se_9） 2015/04/01(水) 15:01

わかりました。
（疑問者） 2015/04/01(水) 15:27

 あ、ごめんなさい.FileSearch使ったことないのでプロパティよく確認していませんでした。
 で、サブフォルダ検索少々お待ちください・・・
（稲葉） 2015/04/01(水) 15:35

 昔作った気がしたので、掘り出しました。

 クラスモジュールを一つ挿入し、オブジェクト名を　clsGetFilePath　とし、以下のコードを入れてください。
    Option Explicit
    Private FolStp  As Long   '掘り進めるフォルダの最大階層（現在のフォルダなら0）
    Private FolDic  As Object 'フォルダの一覧Dictionaryオブジェクト
    Private FilDic  As Object 'ファイルの一覧Dictionaryオブジェクト
    Private FinDic  As Object 'ブック内検索で見つけたファイルの一覧Dictionaryオブジェクト
    Private FstFol  As String '初期フォルダーのパス
    Private EXT     As String '拡張子のフィルタ
    Private Name    As String 'ファイル名のフィルタ
    Private FindStr As String '検索する文字列のフィルタ
    Private FSO     As Object 'フォルダ等を取得する、FileSystemObject
    Private ExcAttr As Long
    Private Cancel  As Boolean
    Enum ExcAttrType
        ReadOnly = 1
        Hidden = 2
        System = 4
        ShortCut = 64
        ReadHid = 3
        ReadSys = 5
        ReadShort = 65
        HidSys = 6
        HidShort = 66
        SysShort = 68
        ReadHidSys = 7
        ReadHidShort = 67
        ReadHidSysShort = 71

        '値   属性
        '0    標準ファイル
        '1    読み取り専用ファイル
        '2    隠しファイル
        '4    システムファイル
        '8    ディスクドライブボリュームラベル (取得のみ可能)
        '16   フォルダまたはディレクトリ (取得のみ可能)
        '32   アーカイブファイル
        '64   リンクまたはショートカット (取得のみ可能)
        '128  圧縮ファイル (取得のみ可能)
    End Enum
    '//実体化時の処理
    Private Sub Class_Initialize()
    '//////////////////////////////
        Set FolDic = CreateObject("Scripting.Dictionary")
        Set FilDic = CreateObject("Scripting.Dictionary")
        Set FinDic = CreateObject("Scripting.Dictionary")
        Set FSO = CreateObject("Scripting.FileSystemObject")
    End Sub

    '//実体破棄時の処理
    Private Sub Class_Terminate()
    '//////////////////////////////
        Set FolDic = Nothing
        Set FilDic = Nothing
        Set FinDic = Nothing
        Set FSO = Nothing
    End Sub

    '■メソッド■
    '■最初のフォルダをセットする
    Public Function GetFirstFolder() As Boolean
    '//////////////////////////////
        GetFirstFolder = False
        If FstFol = "" Then
            With Application.FileDialog(msoFileDialogFolderPicker)
                If .Show = True Then
                    FstFol = .SelectedItems(1) & "\"
                    GetFirstFolder = True
                Else
                    Exit Function
                End If
            End With
        Else
            GetFirstFolder = True
        End If
        FolDic.Add FstFol, ""
    End Function

    '■ファイル名の取得
    Public Function GetFileList() As Boolean
    '//////////////////////////////
        GetSubFolder FstFol
        If FilDic.Count > 0 Then GetFileList = True:  Exit Function
        Dim k
        Dim FilName
        Dim F
        For Each k In FolDic
            On Error Resume Next
                For Each F In FSO.GetFolder(k).Files
                    If Cancel = True Then Exit For
                    If Err = 0 Then
                        If GetAttr(F) Then
                            If F.Name Like Name & EXT Then
                                FilDic.Add F.Path, F.Name
                                Application.StatusBar = "ファイル検索:" & F.Path
                            Else
                                Application.StatusBar = "ファイル検索:No Match" & Time
                            End If
                        End If
                    Else
                        Application.StatusBar = "ファイル検索:スキップ" & Now
                    End If
                    DoEvents
                Next F
            On Error GoTo 0
        Next k
        Application.StatusBar = False
        If FilDic.Count > 0 Then
            GetFileList = True
            Exit Function
        End If
    End Function

    '■サブフォルダを取得するサブプロシジャー（再帰処理）
    Private Sub GetSubFolder(ByVal FPath As String, Optional ByVal Nstp As Long = 0)
    '//////////////////////////////
        'FPath ---フォルダの名前
        'Nstp  ---現在の階層を指定する
        Dim FName  As String
        Dim SubFol As String
        Dim k
        Dim SF
        On Error Resume Next
            For Each SF In FSO.GetFolder(FPath).SubFolders
                If Cancel = True Then Exit For
                If Err > 0 Then
                    Application.StatusBar = "サブフォルダ検索:スキップ" & Now
                    Exit For
                Else
                    If GetAttr(SF) Then
                        SubFol = SubFol & Chr(2) & SF.Path & "\"
                        FolDic.Add SF.Path & "\", ""
                        Application.StatusBar = "サブフォルダ検索:" & SF.Path
                    End If
                    DoEvents
                End If
            Next SF
        On Error GoTo 0
        Application.StatusBar = False
        If Cancel = True Then Exit Sub
        If FolStp > Nstp Then
            For Each k In Split(Mid(SubFol, 2), Chr(2))
                GetSubFolder k, Nstp + 1
            Next k
        End If
    End Sub

    '■ファイル名の取得
    Public Function GetFindStr() As Boolean
    '//////////////////////////////
        GetFindStr = False
        Application.StatusBar = "出力の準備中..."
        Dim xlApp  As Application
        Dim FN
        Set xlApp = CreateObject("Excel.Application")
        EV_SW False, xlApp
        For Each FN In FilDic.keys
            If Cancel = True Then Exit For
            If FindInBook(FN, xlApp) Then
                FinDic.Add FN, ""
            End If
        Next FN
        EV_SW True, xlApp
        xlApp.Quit
        If FinDic.Count > 0 Then
            GetFindStr = True
        End If
    End Function

    '■検索条件をクリア
    Sub Clear()
    '//////////////////////////////
        Set FolDic = CreateObject("Scripting.Dictionary")
        Set FilDic = CreateObject("Scripting.Dictionary")
    End Sub

    '■ファイル（フォルダ）の属性検出
    Private Function GetAttr(ByVal FP As Object) As Boolean
    '//////////////////////////////
        GetAttr = True
        If FP.Attributes And ExcAttr Then GetAttr = False
    End Function

    '■ブック内検索のサブプロシージャ
    Private Function FindInBook(ByVal Target As String, ByVal xlApp As Application) As Boolean
    '//////////////////////////////
        Dim WS As Worksheet
        Dim F As Range
        On Error Resume Next
            With xlApp.Workbooks.Open(Target, ReadOnly:=True)
                If Err = 0 Then
                    For Each WS In .Sheets
                        Application.StatusBar = Replace(Application.StatusBar, ":", ":" & WS.Name)
                        Set F = WS.Cells.Find( _
                                What:=FindStr, _
                                After:=WS.Range("A1"), _
                                LookIn:=xlValues, _
                                LookAt:=xlPart, _
                                SearchFormat:=False)
                        If Not F Is Nothing Then
                            FindInBook = True
                            Exit For
                        End If
                    Next WS
                    .Saved = True
                    .Close (False)
                End If
                DoEvents
            End With
        On Error GoTo 0
    End Function

    '■イベントスイッチ
    Private Function EV_SW(ByVal flg As Boolean, ByRef xlApp As Application)
    '//////////////////////////////
        With xlApp
            '.ScreenUpdating = flg
            '.Calculation = IIf(flg, xlCalculationAutomatic, xlCalculationManual)
            .DisplayAlerts = flg
            .EnableEvents = flg
            .AutomationSecurity = IIf(flg, msoAutomationSecurityByUI, msoAutomationSecurityForceDisable)
            If flg = True Then xlApp.Quit
        End With
    End Function

    '■最初のフォルダを指定する
    Public Function SetFirstFolder(ByVal FirstFolder As String) As Boolean
    '//////////////////////////////
        SetFirstFolder = False
        If Dir(FirstFolder) <> "" Then
            FstFol = FirstFolder
            SetFirstFolder = True
        End If
    End Function

    '■プロパティー■
    '■最大階層数を指定する
    Public Property Let MaxStep(ByVal Steps As Long)
    '//////////////////////////////
        FolStp = Steps
    End Property

    '■拡張子を指定する（例：xls?）
    Public Property Let SetEXT(ByVal FindEXT As String)
    '//////////////////////////////
        EXT = FindEXT
    End Property

    '■検索するファイル名を指定する
    Public Property Let SetName(ByVal FindName As String)
    '//////////////////////////////
        Name = FindName
    End Property

    '■検索除外する属性を指定する
    Public Property Let SetExcAttr(ByVal ExcAttrs As ExcAttrType)
    '//////////////////////////////
        ExcAttr = ExcAttrs
    End Property

    '■検索除外する属性を指定する
    Public Property Let SetFindStr(ByVal StrFind As String)
    '//////////////////////////////
        FindStr = StrFind
    End Property

    '■検索除外する属性を指定する
    Public Property Let clsCancel(ByVal Can As Boolean)
    '//////////////////////////////
        Cancel = Can
    End Property

    '■ファイルのパスを配列にして出力
    Public Property Get FilePathList() As Variant
    '//////////////////////////////
        Application.StatusBar = "出力の準備中..."
        FilePathList = FilDic.keys
        Application.StatusBar = False
    End Property

    '■ブック内検索をして見つけたリストを出力
    Public Property Get FindStrList() As Variant
    '//////////////////////////////

        If FinDic.Count > 0 Then
            FindStrList = FinDic.keys
        End If
        Application.StatusBar = False
    End Property

    '■ファイルの名前を配列にして出力
    Public Property Get FileNameList() As Variant
    '//////////////////////////////
        FileNameList = FilDic.Items
    End Property

    '■ファイル名の件数を出力
    Public Property Get CountFile() As Variant
    '//////////////////////////////
        CountFile = FilDic.Count
    End Property

    '■検索した文字数の件数を出力
    Public Property Get CountFind() As Variant
    '//////////////////////////////
        CountFind = FinDic.Count
    End Property

    '■検索した文字数の件数を出力
    Public Property Let LookIn(DirPath As String)
    '//////////////////////////////
        If FSO.FolderExists(DirPath) Then
            FstFol = DirPath
        End If
    End Property

 標準モジュールに以下のコードを入れて、testを実行してください。
    Sub test()
        Dim clsGFP As clsGetFilePath
        Set clsGFP = New clsGetFilePath
        With clsGFP
            .MaxStep = 2                     'サブフォルダをさかのぼる階層数
            .LookIn = "C:\エクセルの学校\"   '検索を開始するパス　←これをセットしなければ、後でダイヤログで指定できる
            .SetName = "*" & "テスト" & "*"  '検索するファイル名
            .SetEXT = "*.xls?"               '検索する拡張子
            .SetExcAttr = ReadHidSysShort    '検索するファイルの属性（デフォルトは全部）
            If .GetFirstFolder = False Then Exit Sub
            If .GetFileList = False Then Exit Sub
            If .CountFile > 0 Then
                Cells(2, "B").Value = .CountFile
                Cells(Rows.Count, "C").End(xlUp).Offset(1).Resize(.CountFile).Value = Application.Transpose(.FilePathList)
            End If
        End With
    End Sub

（稲葉） 2015/04/01(水) 15:57

長いコードをありがとうございました。

 数行の手直し変更程度では簡単には行かないようですね。
そういう意味ではやはり，excel2003時代のApplication.FileSearchは優れものだったというわけですね。

 あまりに長く複雑そうなので，大変という感じですね。
とりあえずは，サブフォルダーまでは諦めようと思います。

 ありがとうございました。
（疑問者） 2015/04/01(水) 17:29

 いや実際はもっと簡単ですよ。
 質問者さんが変更するところは
 ＞標準モジュールに以下のコードを入れて、testを実行してください。
 標準モジュールに入れたコードだけです。

 全部掲載いただければ、そっくり書き換えてもいいんですが・・・

 ※FileSearch使ったことなかったので、それを再現できそうなもの、少し考えてみます。
 　面白い題材頂いてありがとうございます。

（稲葉） 2015/04/01(水) 17:46

 と思ったら既に代替クラス作ってくれている人いました！
http://d.hatena.ne.jp/xixiixiiixiv/20120806/1344258369

 試してみてください。
（稲葉） 2015/04/01(水) 17:49

 大変済みません
 WScriptでサブフォルダ一気に出せるの忘れてました。
    Sub WScript版()
        Dim DirName   As String
        Dim FileName2 As String
        Dim Files
        DirName = "C:\エクセルの学校\dafdsafdsa\"
        FileName2 = "テスト"
        Files = Split(CreateObject("WScript.Shell").Exec("cmd /C DIR /S /B /O:N """ & DirName & "*" & FileName2 & "*""").StdOut.ReadAll(), vbLf)
        If UBound(Files) > 0 Then
            MsgBox UBound(Files) & "個のファイルが見つかりました"
            Cells(3, "B").Value = UBound(Files)
            Cells(Rows.Count, "C").End(xlUp).Offset(1).Resize(UBound(Files)).Value = Application.Transpose(Files)
        End If
    End Sub

（稲葉） 2015/04/01(水) 18:36

コメント返信：

[ 一覧(最新更新順) ]

[[20150401123111]] 『EXCEL2007での FileSearch 問題』（疑問者） ページの最後に飛ぶ

[[20150401123111]]　『EXCEL2007での FileSearch 問題』（疑問者）　ページの最後に飛ぶ