| |
なんどもスミマセン m(_ _)m
また不具合が見つかりました。
主な変更は ◆か所ですが、他もあちこちブラッシュアップしてますので、
そっくり差し替えてください。
Function File_Search() 'Dirコマンドによるファイル検索（Ver.3）
Dim LookIn As String
Dim Filename As String
Dim SearchSubFolders As Boolean
Dim tmpPath As String
Dim sCmd As String
Dim ng As Long
Dim j As Long
Dim n As Long
Dim io As Integer
Dim buf() As Byte
Dim ss As String
Dim FoundFiles() As String
For j = Cnt(0) To 1 Step -1
LookIn = Left$(TL_Path, Cnt(j)) '検索するフォルダ
SearchSubFolders = True 'Sub Folderも検索する
Filename = WK_Name '検索するファイル名
If Right$(LookIn, 1) <> "\" Then LookIn = LookIn & "\"
'---- Dirコマンドによるサブフォルダを含むファイル名の検索
tmpPath = Environ$("Temp") & "\Dir.tmp" '一時ファイルパス
sCmd = "DIR """ & LookIn & Filename & """ /b/s/a:-D > """ _
& tmpPath & """" '' /b ファイル名のみ
'' /s サブディレクトリも検索
'' /a:-D サブディレクトリー名は表示しない
Debug.Print sCmd
'Dirコマンド実行(tmpファイルに出力)
With CreateObject("WScript.Shell")
ng = .Run("CMD /C " & sCmd, 7, True)
End With
If ng Then
Select Case ng
Case 1: ss = "パス名が不正です" & vbCr & sCmd
Case Else: ss = "ファイル検索時にエラー発生"
End Select
MsgBox ss & vbCr _
& "処理を中断します", , LookIn & Filename
Open_SW = "Error"
Exit Function
End If
If FileLen(tmpPath) < 2 Then
'このパスでは見つからなかったとき
Debug.Print LookIn, Filename, "→ NO FILES"
Open_SW = "Error" '次に検索パスに飛ぶ
Else
'----- Dirコマンドで取得したファイル名を配列に格納
io = FreeFile()
Open tmpPath For Binary As io
ReDim buf(1 To LOF(io))
Get #io, , buf
Close io
Kill tmpPath
ss = StrConv(buf, vbUnicode)
FoundFiles() = Split(ss, vbCrLf)
'同名ファイルが存在した場合、フォルダのパスをセット
For i = 0 To UBound(FoundFiles) - 1
If FoundFiles(i) Like "*" & Filename & "*" Then
WK_Path = FoundFiles(i)
Open_SW = "OK" '取得成功
Exit Function '◆変更
End If
Next
End If
Next j
MsgBox "【" & WK_Name & "】対象ファイルなし" & vbCr _
& "対象ファイルを準備後、処理して下さい。"
End Function
|
|
kanabun
- 14/8/14(木) 23:05 -
