| |
前の「Function GetFilesList」を削除して
以下の2つのプロシージャと入れ替えてください
ただし、ファイル名の抽出は遅く成ると思います
Private Function GetFilesList(vntFilenames As Variant, _
strPath As String, _
vntMark As Variant) As Boolean
' Fso使用版
Dim i As Long
Dim j As Long
Dim vntRead() As Variant
Dim strName As String
Dim lngPos As Long
Dim vntStart As Variant
Dim vntFinish As Variant
Dim lngCount As Long
Dim vntFiles As Variant
Dim strCompe As String
Dim objFso As Object
vntMark = Trim(vntMark)
lngPos = InStr(1, vntMark, "〜", vbBinaryCompare)
If lngPos = 0 Then
GoTo Wayout
End If
'開始日付の取得
vntStart = Left(vntMark, lngPos - 1)
If IsDate(vntStart) Then
vntStart = DateValue(vntStart)
Else
GoTo Wayout
End If
'終了日付の取得
vntFinish = Mid(vntMark, lngPos + 1)
If IsDate(vntFinish) Then
vntFinish = DateValue(vntFinish)
vntFinish = DateSerial(Year(vntFinish), _
Month(vntFinish) + 1, 0)
Else
Exit Function
End If
'FSOのオブジェクトを取得
Set objFso = CreateObject("Scripting.FileSystemObject")
'指定形式のファイル名を取得
strCompe = "^[0-9][0-9][01][0-9][0-3][0-9]$|^[0-9][0-9][01][0-9][0-3][0-9]_[0-9]+$"
If Not GetFileNames(vntFiles, strPath, objFso, strCompe, "txt") Then
GoTo Wayout
End If
'ファイル名の比較
For i = vntStart To vntFinish
'比較パターンを作成
strName = Format(i, "yymmdd") & "*"
'抽出したファイル名と比較
For j = 1 To UBound(vntFiles)
If objFso.GetBaseName(vntFiles(j)) Like strName Then
lngCount = lngCount + 1
ReDim Preserve vntRead(1 To lngCount)
vntRead(lngCount) = vntFiles(j)
End If
Next j
Next i
'ファイルの数が0でなければ
If lngCount > 0 Then
vntFilenames = vntRead
GetFilesList = True
End If
Wayout:
Set objFso = Nothing
End Function
Private Function GetFileNames(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 = .Name
'検索をテスト
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
ReDim vntFilenames(1 To UBound(vntRead))
For i = 1 To UBound(vntRead)
vntFilenames(i) _
= StrConv(strFilePath & "\" & vntRead(i), vbNarrow)
Next i
GetFileNames = True
End If
Wayout:
'フォルダオブジェクトを破棄
Set objFiles = Nothing
Set objFile = Nothing
End Function
|
|
Hirofumi
- 06/1/4(水) 20:38 -
