| |
その2
以下を上記と別な標準モジュールに記述して下さい
Option Explicit
' アクティブなウィンドウのハンドルを取得する関数の宣言
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Public Function GetFolderPath(strPath As String) As Boolean
Const BIF_RETURNONLYFSDIRS = &H1
Const ssfDESKTOP = &H0
Const CSIDL_WINDOWS = &H24
Dim strTitle As String
Dim objFolder As Object
Dim hWnd As Long
'アクティブなWindowのハンドルを取得
hWnd = GetForegroundWindow
' 表示タイトルを指定
strTitle = "フォルダを選択して下さい"
' フォルダ選択ダイアログを表示
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(hWnd, strTitle, _
BIF_RETURNONLYFSDIRS, ssfDESKTOP)
' フォルダを選択したときは
If Not (objFolder Is Nothing) Then
' 選択フォルダを表示
With objFolder
' 親フォルダが存在するときは
If Not (.ParentFolder Is Nothing) Then
' 選択フォルダのフルパスを表示
strPath = .Items.Item.Path
' 親フォルダのときは
Else
' フォルダ名を表示
strPath = .Title
End If
End With
' Folderオブジェクトを破棄
Set objFolder = Nothing
'戻り値にTrueを設定
GetFolderPath = True
End If
If strPath <> "" And Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
End Function
Public Function GetFilesList(vntFileNames As Variant, _
strFilePath As String, _
objFso As Object, _
Optional strNamePattan As String = ".*", _
Optional strExtePattan As String = ".*") As Boolean
Dim i As Long
Dim objFiles As Object
Dim objFile As Object
Dim regExten As Object
Dim regName As Object
Dim vntRead() As Variant
Dim strName As String
'フォルダの存在確認
If Not objFso.FolderExists(strFilePath) Then
GoTo Wayout
End If
'regExtenpのオブジェクトを取得（正規表現を作成）
Set regExten = CreateObject("VBScript.RegExp")
With regExten
'パターンを設定
.Pattern = strExtePattan
'大文字と小文字を区別しないように設定
.IgnoreCase = True
End With
Set regName = CreateObject("VBScript.RegExp")
With regName
'パターンを設定
.Pattern = strNamePattan
'大文字と小文字を区別しないように設定
.IgnoreCase = True
End With
'フォルダオブジェクトを取得
Set objFiles = objFso.GetFolder(strFilePath).Files
'ファイルの数が0でなければ
If objFiles.Count <> 0 Then
For Each objFile In objFiles
With objFile
strName = .Path
'検索をテスト
If regExten.test(objFso.GetExtensionName(strName)) Then
If regName.test(objFso.GetBaseName(strName)) Then
i = i + 1
ReDim Preserve vntRead(1 To i)
vntRead(i) = strName
End If
End If
End With
Next objFile
End If
Set regExten = Nothing
Set regName = Nothing
If i <> 0 Then
vntFileNames = vntRead
GetFilesList = True
End If
Wayout:
'フォルダオブジェクトを破棄
Set objFiles = Nothing
Set objFile = Nothing
End Function
|
|
Hirofumi
- 06/3/5(日) 0:05 -
