' [340.xls]



' [UserForm1] のコード
Option Explicit

Dim File As String

Private Sub CommandButton1_Click()

    '検索用パス名を初期化
    パス名 = ""
    
    'サブマクロの呼出
    フォルダ取得
    
    '指定するフォルダがなかった場合何もしない
    If パス名 = "" Then Exit Sub
    
    '検索で必要な拡張子を変数に格納
    拡張子 = TextBox1.Text
    
    '検索中のメッセージを表示
    Label4.Visible = True
    DoEvents
    
    'サブマクロの呼出 (検索開始)
    serch_on
    
    '"検索中"のメッセージを消す
    Label4.Visible = False
    
End Sub

'クリックイベントではすでに選択された行の場合イベントが発生しません
Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    '選択されたファイルのフルパス、作成日、サイズを取得して表示
    MsgBox "---- 選択したファイルの情報 ----" & Chr(10) & Chr(10) & "フルパス = " & ListBox1.Value _
    & Chr(10) & "作成日　 = " & Format(FileDateTime(ListBox1.Value), "yyyy/mm/dd hh:mm:ss") _
    & Chr(10) & "サイズ　 = " & Format(FileLen(ListBox1.Value), "#,###") & " Byte"
  
End Sub

Private Sub TextBox1_Change()

    '入力された文字を検査
    '数字と"."があった場合入力文字を拒否する
    If IsNumeric(TextBox1.Value) = True Or _
            InStr(TextBox1.Value, ".") Then
        TextBox1.Value = ""
        Exit Sub
    End If

End Sub

Private Sub UserForm_Initialize()

    'リストボックスの初期化(プロパティー設定)
    With ListBox1
        .ColumnCount = 2
        .TextColumn = 2
        .ColumnWidths = "0 cm;6.3 cm"
    End With
    
        'フォームの起動位置を設定
        Me.StartUpPosition = 2
        
End Sub


' [Module1] のコード
'★★☆　指定フォルダ内の全ファイル名を取得する　☆★★

Option Explicit

'-------[フォルダの参照]ダイアログの WinAPI関連 ここから--------

Public Type BROWSEINFO
    hwndOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

'ルートフォルダ定数
Public Const CSIDL_DESKTOP = &H0

'特殊フォルダを選択させない
Public Const BIF_BROWSEFORCOMPUTER = 1

'[フォルダの参照]ダイアログを表示するAPI関数
Public Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBROWSEINFO As BROWSEINFO) As Long

'SHBrowseForFolderで得られた値からフフォルダのパスを取得するAPI関数
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

'メモリブロックを開放するAPI関数
Declare Function CoTaskMemFree Lib "OLE32.dll" _
    (ByVal pv As Long) As Long
    
Public pathname As String

'---------------------ここまで------------------------

Public パス名 As String
Public 拡張子 As String

Sub start()

    UserForm1.Show

End Sub

Sub フォルダ取得()
Dim typBROWSEINFO As BROWSEINFO
Dim lngFoldPointer As Long

    On Error GoTo ErrHndl
    With typBROWSEINFO
        .lpszTitle = "フォルダの場所を選択して下さい"
        
        '特殊フォルダを選択させない
        .ulFlags = BIF_BROWSEFORCOMPUTER
    End With

    '[フォルダの参照]ダイアログを呼び出す
    lngFoldPointer = SHBrowseForFolder(typBROWSEINFO)

        If lngFoldPointer = 0 Then
            Exit Sub
        End If
  

    'パスの長さが256文字に制限される。
    pathname = String$(256, vbNullChar)
    
    'SHBrowseForFolderで得られた値からフォルダパスを取得
    SHGetPathFromIDList lngFoldPointer, pathname

    '   Null文字以下を削除
    pathname = Left(pathname, InStr(1, pathname, vbNullChar) - 1)

    パス名 = pathname
    
    '割り当てられたメモリを開放
    Call CoTaskMemFree(lngFoldPointer)
    
    UserForm1.Label2.Caption = パス名
    UserForm1.CommandButton1.Enabled = True
    
    Exit Sub
    

ErrHndl:

    MsgBox "予期せぬエラーが発生しました。"
    パス名 = ""

End Sub

Sub serch_on()

'2次元配列の宣言
Dim fl() As Variant

Dim i
    
    'リストボックスの履歴を削除
    UserForm1.ListBox1.Clear
        
        '検索開始
        With Application.FileSearch
        
            '検索条件を既定の設定にリセット
            .NewSearch
            
            '指定したファイル検索の対象となるフォルダを設定
            .LookIn = パス名
            
            '指定したフォルダのすべてのサブフォルダも検索の対象にする
            .SearchSubFolders = True
            
            '検索するファイルの名前を設定
            .FileName = "*." & 拡張子
            
                If .Execute <= 0 Then Exit Sub
                'この時点で検索は終了しています
                '同時に検索結果を調べ "なし" の場合マクロから抜ける
                
                '検索結果があまりに多いときはメッセージ表示へ飛ぶ
                'リストボックスへの書込を中止する
                If .FoundFiles.Count > 9000 Then GoTo errhnd
                    
                    'エラーの発生を無視する
                    On Error Resume Next
                    
                    '配列の要素数を再定義
                    ReDim fl(1 To .FoundFiles.Count, 1)
                    
                        '検索結果の数に達するまで繰り返し作業の開始
                        For i = 1 To .FoundFiles.Count
                            
                            '2次元配列片方に検索結果のフルパス名を格納
                            fl(i, 0) = .FoundFiles(i)
                            
                            '2次元配列のもう一方に検索結果のファイル名を格納
                            fl(i, 1) = Dir(.FoundFiles(i))
                        Next i
                    
                    '配列に格納されてある全てのデータを
                    'リストボックスにコピーする
                    UserForm1.ListBox1.List = fl
        
        End With

    'リストボックスの格納されてあるデータ数を表示
    UserForm1.Label1.Caption = UserForm1.ListBox1.ListCount

Exit Sub

'エラーメッセージの表示
errhnd:

    MsgBox "検索ファイル数が 9,000 を越えました、多すぎます" _
    & Chr(10) & "ファイルの種類やフォルダを絞って下さい"
    
End Sub