VERSION 5.00
Begin VB.Form frmDirFind 
   BorderStyle     =   1  '固定(実線)
   Caption         =   "フォルダ検索"
   ClientHeight    =   2280
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   9315
   BeginProperty Font 
      Name            =   "ＭＳ ゴシック"
      Size            =   12
      Charset         =   128
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmDirFind.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2280
   ScaleWidth      =   9315
   StartUpPosition =   2  '画面の中央
   Begin VB.CommandButton cmdFindPathSet 
      Caption         =   "..."
      BeginProperty Font 
         Name            =   "ＭＳ ゴシック"
         Size            =   9
         Charset         =   128
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   8520
      TabIndex        =   3
      Top             =   360
      Width           =   495
   End
   Begin VB.TextBox txtFindPath 
      Height          =   375
      Left            =   240
      MaxLength       =   1022
      TabIndex        =   2
      Top             =   360
      Width           =   8295
   End
   Begin VB.CheckBox chkSortCheck 
      Caption         =   "ソートしてファイルに書き込み"
      Height          =   255
      Left            =   240
      TabIndex        =   4
      Top             =   840
      Width           =   6495
   End
   Begin VB.CommandButton cmdEnd 
      Caption         =   "終了"
      Height          =   615
      Left            =   5040
      TabIndex        =   1
      Top             =   1440
      Width           =   3735
   End
   Begin VB.ListBox lstDirFind 
      Height          =   300
      IMEMode         =   3  'ｵﾌ固定
      Left            =   0
      Sorted          =   -1  'True
      TabIndex        =   5
      Top             =   2160
      Visible         =   0   'False
      Width           =   1455
   End
   Begin VB.CommandButton cmdDirFind 
      Caption         =   "フォルダ検索"
      Height          =   615
      Left            =   480
      TabIndex        =   0
      Top             =   1440
      Width           =   3735
   End
   Begin VB.Label lblFindTitle 
      AutoSize        =   -1  'True
      BackStyle       =   0  '透明
      Caption         =   "検索先"
      Height          =   240
      Left            =   240
      TabIndex        =   6
      Top             =   120
      Width           =   720
   End
End
Attribute VB_Name = "frmDirFind"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Const FILE_ATTRIBUTE_READONLY            As Long = &H1
Private Const FILE_ATTRIBUTE_HIDDEN              As Long = &H2
Private Const FILE_ATTRIBUTE_SYSTEM              As Long = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY           As Long = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE             As Long = &H20
Private Const FILE_ATTRIBUTE_ENCRYPTED           As Long = &H40
Private Const FILE_ATTRIBUTE_NORMAL              As Long = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY           As Long = &H100
Private Const FILE_ATTRIBUTE_SPARSE_FILE         As Long = &H200
Private Const FILE_ATTRIBUTE_REPARSE_POINT       As Long = &H400
Private Const FILE_ATTRIBUTE_COMPRESSED          As Long = &H800
Private Const FILE_ATTRIBUTE_OFFLINE             As Long = &H1000
Private Const FILE_ATTRIBUTE_NOT_CONTENT_INDEXED As Long = &H2000

Private Const MAX_PATH As Long = 260

Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

Private Type SYSTEMTIME
        wYear As Integer
        wMonth As Integer
        wDayOfWeek As Integer
        wDay As Integer
        wHour As Integer
        wMinute As Integer
        wSecond As Integer
        wMilliseconds As Integer
End Type

Private Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * MAX_PATH
        cAlternate As String * 14
End Type

Private 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

Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Private Const strFindFileExe As String = "*.*"

Private Const SORT_OFF As Long = 0
Private Const SORT_ON_FILE_LIST_BOX As Long = 1000
Private lngListSortOn As Long

Private Const CSIDL_DESKTOP = &H0
Private Const BIF_CLOSE = &H1

Private Sub cmdDirFind_Click()
    Dim lngi As Long
    Dim strFindPath As String
    Dim strTitleHeader As String
    
    '検索先設定
    strFindPath = Trim(txtFindPath.Text)
    If Right(strFindPath, 1) <> "\" Then
        '後ろに￥が付いていない場合は付ける
        strFindPath = strFindPath & "\"
    End If
    '指定先のフォルダが見つけられない場合
    If Dir(strFindPath, vbNormal) = "" Then
        'エラーメッセージを表示
        MsgBox "指定のフォルダが見つかりません。" & vbCrLf & "設定し直してください。", vbQuestion, "フォルダ検索失敗"
        'フォーカスをパス設定ボックスに設定
        txtFindPath.SetFocus
        Exit Sub
    End If

    'ソート設定
    If chkSortCheck.Value = 1 Then
        'ソートする
        lngListSortOn = SORT_ON_FILE_LIST_BOX
    Else
        'ソートしない
        lngListSortOn = SORT_OFF
    End If

    'ボタン連打防止設定
    cmdDirFind.Enabled = False
    cmdEnd.Enabled = False
    txtFindPath.Enabled = False
    cmdFindPathSet.Enabled = False
    chkSortCheck.Enabled = False

    'リストクリア
    lstDirFind.Clear
    lstDirFind.Refresh

    'ログ出力ファイルオープン
    Open App.Path & "\" & App.EXEName & ".Log" For Append Access Write Lock Write As #123

    'ファイルヘッダ作成
    strTitleHeader = strFindPath & vbTab & Trim(Now)
    Print #123, ""
    Print #123, strTitleHeader
    Print #123, ""

    'ファイルリスト取得
    Call GetFilesList(strFindPath)

    'リストソートの場合
    If lngListSortOn = SORT_ON_FILE_LIST_BOX And lstDirFind.ListCount <> 0 Then
        'リストボックスのデータを全てファイルに書き込む
        For lngi = 0 To lstDirFind.ListCount - 1 Step 1
            'ログ出力ファイルに追加
            Print #123, lstDirFind.List(lngi)
        Next lngi
    End If

    'ログ出力ファイルクローズ
    Close #123

    'ボタン連打防止解除
    cmdDirFind.Enabled = True
    cmdEnd.Enabled = True
    txtFindPath.Enabled = True
    cmdFindPathSet.Enabled = True
    chkSortCheck.Enabled = True

    MsgBox "フォルダ検索が完了しました。", vbInformation, "検索完了"

End Sub

Private Sub cmdEnd_Click()
    '終了
    Unload Me
End Sub

Private Sub cmdFindPathSet_Click()
    Dim lngRet As Long
    Dim strSelectPath As String
    Dim broInfo As BROWSEINFO
    
    'ダイアログの設定
    With broInfo
        .hwndOwner = Me.hWnd
        .lpszTitle = "検索先フォルダの選択"
        .pidlRoot = CSIDL_DESKTOP
        .ulFlags = BIF_CLOSE
    End With
    'ダイアログ表示
    lngRet = SHBrowseForFolder(broInfo)
    'ＯＫボタン押下の場合
    If lngRet <> 0 Then
        '初期化
        strSelectPath = String(1024, Chr(0))
        '選択されたパスを取得
        lngRet = SHGetPathFromIDList(lngRet, strSelectPath)
        'NULLを削除
        strSelectPath = CutNull(strSelectPath)
        'パスを設定
        txtFindPath.Text = strSelectPath
    End If
End Sub

Private Sub Form_Load()
    '初期化
    txtFindPath.Text = App.Path
End Sub

Private Sub Form_Unload(Cancel As Integer)
    '解放
    Set frmDirFind = Nothing
    End
End Sub

Private Sub GetFilesList(strFindPath As String)
    Dim lngRet As Long
    Dim lngFindHand As Long
    Dim strGetFind As String
    Dim strGetFileName As String
    Dim typFindData As WIN32_FIND_DATA

    'フォルダ以外のみの属性を検索設定
    typFindData.dwFileAttributes = FILE_ATTRIBUTE_OFFLINE + _
                                   FILE_ATTRIBUTE_COMPRESSED + _
                                   FILE_ATTRIBUTE_TEMPORARY + _
                                   FILE_ATTRIBUTE_NORMAL + _
                                   FILE_ATTRIBUTE_ARCHIVE + _
                                   FILE_ATTRIBUTE_SYSTEM + _
                                   FILE_ATTRIBUTE_HIDDEN + _
                                   FILE_ATTRIBUTE_READONLY
    'ファイル検索
    lngFindHand = FindFirstFile(strFindPath & strFindFileExe, typFindData)
    If lngFindHand > 0 Then
        'フォルダの全てを取得
        Do
            '取得したファイル名を設定
            strGetFileName = CutNull(typFindData.cFileName)
            '自フォルダの場合以外でフォルダ以外の場合
            If strGetFileName <> "." And _
               strGetFileName <> ".." And _
               ((typFindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
                '自己ファイルは出力しない
                If UCase(strGetFileName) <> UCase(App.EXEName & ".exe") And _
                   UCase(strGetFileName) <> UCase(App.EXEName & ".log") Then
                    'リストに追加
                    Call WriteDataStream(strFindPath & strGetFileName, _
                                         typFindData)
                End If
            End If
            '次のを検索
            lngRet = FindNextFile(lngFindHand, typFindData)
        Loop While lngRet = 1
        '検索ハンドル解放
        lngRet = FindClose(lngFindHand)
    End If

    'フォルダのみの属性を検索設定
    typFindData.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY
    'フォルダ検索
    lngFindHand = FindFirstFile(strFindPath & "*.*", typFindData)
    If lngFindHand > 0 Then
        Do
            '取得したファイル名を設定
            strGetFileName = CutNull(typFindData.cFileName)
            '自フォルダの場合以外でフォルダの場合
            If strGetFileName <> "." And _
               strGetFileName <> ".." And _
               ((typFindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY) Then
                'リストに追加
                Call WriteDataStream(strFindPath & strGetFileName, _
                                     typFindData)
                'ファイルリスト取得
                Call GetFilesList(strFindPath & strGetFileName & "\")
            End If
            '次が有る場合
            lngRet = FindNextFile(lngFindHand, typFindData)
        Loop While lngRet = 1
        '検索ハンドル解放
        lngRet = FindClose(lngFindHand)
    End If
End Sub

Private Function CutNull(strCutString As String) As String
    'NULLが含まれていたら以降を削除する
    If InStr(1, strCutString, vbNullChar, vbTextCompare) > 0 Then
        'NULL削除
        CutNull = Left(strCutString, InStr(1, strCutString, vbNullChar, vbTextCompare) - 1)
    Else
        'NULL無し
        CutNull = strCutString
    End If
End Function

Private Function Long2Date(filFileTime As FILETIME) As String
    Dim filFileTimeRet As FILETIME
    Dim sysSystemDateRet As SYSTEMTIME

    'ローカルタイムからファイルタイムに変換
    Call FileTimeToLocalFileTime(filFileTime, filFileTimeRet)
    'ファイルタイムからシステムタイムに変換
    Call FileTimeToSystemTime(filFileTimeRet, sysSystemDateRet)

    'ファイル更新日付を返却値設定
    Long2Date = Format(DateSerial(sysSystemDateRet.wYear, _
                                  sysSystemDateRet.wMonth, _
                                  sysSystemDateRet.wDay) & " " & _
                       TimeSerial(sysSystemDateRet.wHour, _
                                  sysSystemDateRet.wMinute, _
                                  sysSystemDateRet.wSecond), _
                       "YYYY/MM/DD HH:NN:SS")
End Function

Private Sub WriteDataStream(strWritePathString As String, typFindData As WIN32_FIND_DATA)
    Dim strWriteStringWork As String

    'ファイルパスを設定
    strWriteStringWork = strWritePathString
    'フォルダでない場合
'    If (typFindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
        strWriteStringWork = strWritePathString & vbTab & Long2Date(typFindData.ftLastWriteTime)
        'ファイルサイズを設定
        strWriteStringWork = strWriteStringWork & vbTab & CStr(typFindData.nFileSizeLow)
'    End If

    'ソートしてファイルに書き込みの場合
    If lngListSortOn = SORT_ON_FILE_LIST_BOX Then
        'リストボックスに追加
        Call lstDirFind.AddItem(strWriteStringWork)
    Else
        'ログ出力ファイルに追加
        Print #123, strWriteStringWork
    End If
End Sub