自治会活動のEXCEL（ファイル調査）(2/4)

ファイル調査ツール(EXCEL)について説明します。

検索場所の設定
出力項目
サブフォルダ検索条件
ファイル名検索条件
リスト出力
ファイル検索
ファイル読込

検索場所の設定

検索場所の左側の□釦を押下すると検索場所を選択するダイアログが開きます。

Private Const CMENU = "Menu"
Private Const CSRCHPATH = "D8"

Public Sub cmdReferPath()
    Call ReferPath(0)       
End Sub
Public Sub ReferPath(v)
    With ThisWorkbook.Worksheets(CMENU)
        Dim vPath
        vPath = .Range(CSRCHPATH).Value
        If InStr(vPath, ":") = 0 And InStr(vPath, Application.PathSeparator & Application.PathSeparator) = 0 Then
            vPath = ThisWorkbook.Path & Application.PathSeparator & vPath
        End If
        If SetReferPath(vPath) = False Then Exit Sub
        If InStr(vPath, ThisWorkbook.Path & Application.PathSeparator) <> 0 Then
            .Range(CSRCHPATH).Value = Replace(vPath, ThisWorkbook.Path & Application.PathSeparator, "")
        Else
            .Range(CSRCHPATH).Value = vPath
        End If
    End With
End Sub
Private Function SetReferPath(ByRef vPath) As Boolean
    Dim fd As FileDialog
    Dim Ans
    
    SetReferPath = False
    Dim sFolder As String
    sFolder = CStr(vPath)
    If Dir(sFolder, vbDirectory) = "" Then
        sFolder = ActiveWorkbook.Path & Application.PathSeparator
    End If
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "検索場所の設定"
        .InitialFileName = sFolder    
        Ans = .Show
        If Ans = -1 Then
            sFolder = .SelectedItems(1)
            If Right(sFolder, 1) <> Application.PathSeparator Then
                sFolder = sFolder & Application.PathSeparator
            End If
            vPath = sFolder
            SetReferPath = True
        End If
    End With
End Function

[cmdReferPath]が□釦に登録されているマクロです。
33行目から46行目でフォルダを選択する画面を表示します。
15行目から17行目で選択したフォルダ位置がツールの設置からの相対パスで検索場所が設定されます。

出力項目

検索結果の出力項目を設定します。

File: ファイル名を取出す
Folder: フォルダ名を取出す
Folder & File: フォルダ名とファイル名を取出す

ファイル検索処理を「clsSearchFile」で実装しています。出力項目はそのItemModeプロパティで設定します。

Private Const CMENU = "Menu"
Private Const CSRCHPATH = "D8"

    Dim oSF As New clsSearchFile
    With oSF
        .Path = vPath
        Select Case vItemMode
            Case CITEMMODE0
                .ItemMode = 0
            Case CITEMMODE1
                .ItemMode = 1
            Case CITEMMODE2
                .ItemMode = 2
            Case Else
        End Select
        Call .ExecSearch
    End With

「clsSearchFile」のプロパティ実装処理です。

'           出力項目
Public Property Get ItemMode() As Variant
    ItemMode = mvItemMode
End Property
Public Property Let ItemMode(ByVal vNewValue As Variant)
    If vNewValue < 0 Or vNewValue > 2 Then Exit Property
    mvItemMode = vNewValue
End Property

サブフォルダ検索条件

検索場所に対してその下位フォルダも検索するかどうかを指定可能です。また、特定のサブフォルダ（複数）だけ、検索を行うことも出来ます。逆に、特定のサブフォルダ（複数）は検索対象から外すことも出来ます。

これらは、「clsSearchFile」のプロパティで指定します。

SubfAddres:　サブフォルダアドレス
DirAddress: 無効フォルダアドレス
SubfCover: サブフォルダ検索の有効／無効

まずは、検索処理でのプロパティ設定です。

    Private Const CMENU = "Menu"
    Private Const CSRCHPATH = "D8"
　　Private Const CSRCHSUBF = "D19"
　　Private Const CNDIRADDR = "E19"  
    With ThisWorkbook.Worksheets(CMENU)
        With .Range(CSRCHPATH)
            Dim vSubfCover
            If Left(.Offset(1).Text, 1) = "○" Then
                vSubfCover = True
            Else
                vSubfCover = False
            End If
        End With
    End With
　　Dim oSF As New clsSearchFile
    With oSF
        .CondSheet = CMENU
        .SubfAddress = CSRCHSUBF
        .FileAddress = CFILEADDR
        .DirAddress = CNDIRADDR
        .SubfCover = vSubfCover
        Call .ExecSearch
    End With

次に、「clsSearchFile」のプロパティ実装処理です。

'           ｻﾌﾞﾎﾙﾀﾞｱﾄﾞﾚｽ
Public Property Get SubfAddress() As String
    SubfAddress = msSubfAddress
End Property
Public Property Let SubfAddress(ByVal vNewValue As String)
    ReDim mvSubfNames(1 To 1)
    msSubfAddress = vNewValue
    If msSubfAddress = "" Then Exit Property
    With ThisWorkbook.Worksheets(msCondSheet).Range(msSubfAddress)
        Dim vS, vE
        If .Offset(0).Value = "" Then Exit Property
        vS = .Offset(0).Row
        If .Offset(1).Value = "" Then
            mvSubfNames(1) = Trim(CStr(.Offset(0).Value))
            Exit Property
        End If
        vE = .Offset(0).End(xlDown).Row
        ReDim mvSubfNames(1 To vE - vS + 1)
        Dim i
        For i = 1 To UBound(mvSubfNames)
            mvSubfNames(i) = Trim(CStr(.Offset(i - 1, 0).Value))
        Next i
    End With
End Property
'           無効ﾎﾙﾀﾞｱﾄﾞﾚｽ
Public Property Get DirAddress() As String
    DirAddress = msDirAddress
End Property
Public Property Let DirAddress(ByVal vNewValue As String)
    ReDim mDirNames(1 To 1)
    msDirAddress = vNewValue
    If msDirAddress = "" Then Exit Property
    With ThisWorkbook.Worksheets(msCondSheet).Range(msDirAddress)
        Dim vS, vE
        If .Offset(0).Value = "" Then Exit Property
        vS = .Offset(0).Row
        If .Offset(1).Value = "" Then
            mDirNames(1) = CStr(.Offset(0).Value)
            Exit Property
        End If
        vE = .Offset(0).End(xlDown).Row
        ReDim mDirNames(1 To vE - vS + 1)
        Dim i
        For i = 1 To UBound(mDirNames)
            mDirNames(i) = CStr(.Offset(i - 1, 0).Value)
        Next i
    End With
End Property
'           ｻﾌﾞﾎﾙﾀﾞ検索対象
Public Property Get SubfCover() As Boolean
    SubfCover = mbSubfCover
End Property
Public Property Let SubfCover(ByVal vNewValue As Boolean)
    mbSubfCover = vNewValue
End Property

ファイル名検索条件

ファイルタイプ : 検索対象となるファイルタイプを指定します。空白の時は全てのタイプが対象となります。複数の場合は、[;]で区切ります。(例) .xls; .txt

無効ファイルタイプ: 検索対象としないファイルタイプを指定します。検索対象ファイル名指定した名称が含まれるファイル名のみ取出します。

開始日と終了日: 対象とするファイルの最終更新期間(日付)を指定が指定可能です。空白の場合は指定なし期間となります。

検索処理でのプロパティ設定です。

FileType: ファイルタイプ
NonTYpe:　無効ファイルタイプ
StartDate:　開始日
EndDate:　終了日

　　Private Const CMENU = "Menu"
　　Private Const CSRCHTYPE = "D11"
　　Private Const CTERMADDR = "D14"
    With ThisWorkbook.Worksheets(CMENU)
        With .Range(CSRCHTYPE)
            Dim vFileType, vNonType
            vFileType = .Offset(0).Text
            vNonType = .Offset(1).Text
        End With
        With .Range(CTERMADDR)
            Dim vStartDate, vEndDate
            vStartDate = .Offset(0).Value
            vEndDate = .Offset(1).Value
        End With
    End With
    Dim oSF As New clsSearchFile
    With oSF
        .FileType = vFileType
        .NonType = vNonType
        .StartDate = vStartDate
        .EndDate = vEndDate
        Call .ExecSearch
    End With

次に、「clsSearchFile」のプロパティ実装処理です。

'           ﾌｧｲﾙﾀｲﾌﾟ
Public Property Get FileType() As String
    FileType = msFileType
End Property
Public Property Let FileType(ByVal vNewValue As String)
    msFileType = vNewValue
End Property
'           無効ﾌｧｲﾙﾀｲﾌﾟ
Public Property Get NonType() As String
    NonType = msNonType
End Property
Public Property Let NonType(ByVal vNewValue As String)
    msNonType = vNewValue
End Property
'           期間開始日
Public Property Get StartDate() As Variant
    StartDate = mvStartDate
End Property
Public Property Let StartDate(ByVal vNewValue As Variant)
    mvStartDate = vNewValue
    If mvStartDate <> "" Then
        mbStartFlag = True
    End If
End Property
'           期間終了日
Public Property Get EndDate() As Variant
    EndDate = mvEndDate
End Property
Public Property Let EndDate(ByVal vNewValue As Variant)
    mvEndDate = vNewValue
    If mvEndDate <> "" Then
        mbEndFlag = True
    End If
End Property

リスト出力

ファイル名：このツール以外のファイルに検索結果を出力することが出来ます。空白の場合はこのツール内のシートです。

シート名：指定したシートに検索結果を出力します。

開始行：シートの何行目から検索結果を出力するかを指定します。０行目を指定した場合、既存のリストの後ろに検索結果を追加することが出来ます。

出力先の項目は、A列からF列に下記項目が出力されます。

No
Folder
File
Date
Size
FullPath

シートに出力する処理を「clsListFile」として実装しています。ファイル検索処理「clsSeachFile」で検索結果のファイルコレクションを「clsListFile」に渡してシートに出力しています。

まずは、検索処理です。設定しているプロパティおよびメッソドは、下記の通りです。

BookName:　ファイル名
SheetName:　シート名
ListStaRow:　開始行
Files: 検索結果ファイルコレクション
OutList リスト出力（メッソド）

　　Private Const CMENU = "Menu"
　　Private Const CLISTCOND = "F14"
    With ThisWorkbook.Worksheets(CMENU)
        With .Range(CLISTCOND)
            Dim vBookName, vSheetName, vListStaRow
            vBookName = .Offset(0).Text
            vSheetName = .Offset(1).Text
            vListStaRow = .Offset(2).Value
        End With
    End With
    Dim oSF As New clsSearchFile
    With oSF
        Call .ExecSearch
    End With
    Dim oLF As New clsListFile
    With oLF
        If vBookName <> "" Then
            .BookName = vBookName
        End If
        .SheetName = vSheetName
        .ListStaRow = vListStaRow
        Set .Files = oSF.Files
        Call .OutList
    End With

次に、「clsListFile」の実装処理です。

Private Const CPOSNO = 0
Private Const CPOSPATH = 1
Private Const CPOSNAME = 2
Private Const CPOSDATE = 3
Private Const CPOSSIZE = 4
Private Const CPOSFULL = 5
Private msBookName As String 
Private msSheetName As String
Private mvListStaRow As Variant
Private moFiles As Collection
'           初期化
Private Sub Class_Initialize()
    msBookName = ActiveWorkbook.Name
    msSheetName = ActiveSheet.Name
    mvListStaRow = 1
End Sub
'           ﾌﾞｯｸ名
Public Property Get BookName() As String
    BookName = msBookName
End Property
Public Property Let BookName(ByVal vNewValue As String)
    msBookName = vNewValue
End Property
'           ｼｰﾄ名
Public Property Get SheetName() As String
    SheetName = msSheetName
End Property
Public Property Let SheetName(ByVal vNewValue As String)
    msSheetName = vNewValue
End Property
'           開始行
Public Property Get ListStaRow() As Variant
    ListStaRow = mvListStaRow
End Property
Public Property Let ListStaRow(ByVal vNewValue As Variant)
    mvListStaRow = vNewValue
End Property
'           ﾌｧｲﾙｺﾚｸｼｮﾝ
Public Property Set Files(ByRef vNewValue As Collection)
    Set moFiles = vNewValue
End Property
'           ﾘｽﾄ出力
Public Sub OutList()
    With Workbooks(msBookName).Worksheets(msSheetName)
        Dim vNo, vStaRow
        If mvListStaRow = 0 Then
            vStaRow = 1
            If .Range("A1").Offset(1).Value = "" Then
                vNo = 1
            Else
                vNo = .Range("A1").End(xlDown).Row
            End If
        Else
            vStaRow = mvListStaRow - 1
            Dim StaAddr, EndAddr
            StaAddr = .Range("A1").Offset(mvListStaRow - 1, CPOSNO).Address
            EndAddr = .Range("A1").Offset(mvListStaRow - 1, CPOSFULL).End(xlDown).Address
            .Range(StaAddr & ":" & EndAddr).ClearContents
            vNo = 1
        End If
        If moFiles Is Nothing Then Exit Sub
        If moFiles.Count <= 0 Then Exit Sub
        
        With .Range("A1").Offset(vStaRow)
            Dim Obj As Object
            Dim oFile As File
            Dim oFolder As Folder
            For Each Obj In moFiles
                Select Case TypeName(Obj)
                    Case "File"
                        Set oFile = Obj
                        .Offset(vNo - 1, CPOSNO) = vNo
                        .Offset(vNo - 1, CPOSNAME) = oFile.Name
                        .Offset(vNo - 1, CPOSDATE) = oFile.DateLastModified
                        .Offset(vNo - 1, CPOSSIZE) = oFile.Size
                        If InStr(oFile.Path, ThisWorkbook.Path & Application.PathSeparator) <> 0 Then
                            .Offset(vNo - 1, CPOSFULL) = Replace(oFile.Path, ThisWorkbook.Path & Application.PathSeparator, "")
                        Else
                            .Offset(vNo - 1, CPOSFULL) = oFile.Path
                        End If
                        vNo = vNo + 1
                    Case "Folder"
                        If .Offset(vNo - 1, CPOSFULL) <> "" Then
                            vNo = vNo + 1
                        End If
                        Set oFolder = Obj
                        .Offset(vNo - 1, CPOSNO) = vNo
                        .Offset(vNo - 1, CPOSPATH) = oFolder.Name
                        .Offset(vNo - 1, CPOSFULL) = oFolder.Path
                    Case Else
                End Select
            Next
        End With
    End With
End Sub

ファイル検索

「検索」ボタンには「cmdSearchFile」マクロが登録されています。

ファイル検索処理の完全なソースリストを記載します。

22行めで検索場所を取出し、23行目から25行目で相対パス→絶対パスに変換しています。

Path：　　　検索場所の設定　　　　　　 (55行目)
ExecSearch: ファイル検索実行(メッソド)　(74行目)

Private Const CMENU = "Menu"
Private Const CSRCHPATH = "D8"
Private Const CITEMMODE = "F9"
Private Const CSRCHTYPE = "D11"
Private Const CTERMADDR = "D14"
Private Const CLISTCOND = "F14"
Private Const CFILEADDR = "C19"
Private Const CSRCHSUBF = "D19"
Private Const CNDIRADDR = "E19"
Private Const CITEMMODE0 = "Folder & File"
Private Const CITEMMODE1 = "Folder"
Private Const CITEMMODE2 = "File"
'       「検索」実行
Public Sub cmdSearchFile()
    Call SearchFile(0)
End Sub
'       ﾌｧｲﾙ検索
Public Sub SearchFile(v)
    With ThisWorkbook.Worksheets(CMENU)
        With .Range(CSRCHPATH)
            Dim vPath, vSubfCover
            vPath = .Offset(0).Text
            If InStr(vPath, ":") = 0 And InStr(vPath, Application.PathSeparator & Application.PathSeparator) = 0 Then
                vPath = ThisWorkbook.Path & Application.PathSeparator & vPath
            End If
            If Left(.Offset(1).Text, 1) = "○" Then
                vSubfCover = True
            Else
                vSubfCover = False
            End If
        End With
        With .Range(CITEMMODE)
            Dim vItemMode
            vItemMode = .Offset(0).Text
        End With
        With .Range(CSRCHTYPE)
            Dim vFileType, vNonType
            vFileType = .Offset(0).Text
            vNonType = .Offset(1).Text
        End With
        With .Range(CTERMADDR)
            Dim vStartDate, vEndDate
            vStartDate = .Offset(0).Value
            vEndDate = .Offset(1).Value
        End With
        With .Range(CLISTCOND)
            Dim vBookName, vSheetName, vListStaRow
            vBookName = .Offset(0).Text
            vSheetName = .Offset(1).Text
            vListStaRow = .Offset(2).Value
        End With
    End With
    Dim oSF As New clsSearchFile
    With oSF
        .Path = vPath
        Select Case vItemMode
            Case CITEMMODE0
                .ItemMode = 0
            Case CITEMMODE1
                .ItemMode = 1
            Case CITEMMODE2
                .ItemMode = 2
            Case Else
        End Select
        .FileType = vFileType
        .NonType = vNonType
        .StartDate = vStartDate
        .EndDate = vEndDate
        .CondSheet = CMENU
        .SubfAddress = CSRCHSUBF
        .FileAddress = CFILEADDR
        .DirAddress = CNDIRADDR
        .SubfCover = vSubfCover
        Call .ExecSearch
    End With
    Dim oLF As New clsListFile
    With oLF
        If vBookName <> "" Then
            .BookName = vBookName
        End If
        .SheetName = vSheetName
        .ListStaRow = vListStaRow
        Set .Files = oSF.Files
        Call .OutList
    End With
    If vBookName <> "" Then
        Workbooks(vBookName).Activate
    Else
        ThisWorkbook.Activate
    End If
    Worksheets(oLF.SheetName).Activate
End Sub

「clsSearchFile」の検索処理です。

1行目から17行目はクラス内の変数で19行目から34行目で初期化を行い、36行目から46行目で後処理を行っています。

ファイル検索処理は、62行目から95行目のExecSearchメソッドです。この関数の中でフォルダの中の検索対象ファイルを取出すFileSearch関数を呼び出しています。

FileSearch関数は99行目から135行目で、130行目に自分自身を再帰コール（リエントラント）を行っています。

139行目から189行目のIsFikeName関数はファイルタイプの有効・無効判定や検索対象ファイル名かどうかの判定を行っています。

193行目から203行目のIsDirName関数は、対象外フォルダの判定を行っています。

207行目から216行目のIsTermDate関数は、検索したファイルの最新更新日付が開始日から終了日内であるかどうかの判定です。

Private msPath As String           '検索対象ﾊﾟｽ
Private mvStartDate As Variant      '期間開始日
Private mvEndDate As Variant        '期間終了日
Private msCondSheet As String       '条件ｼｰﾄ名
Private msSubfAddress As String     'ｻﾌﾞﾎﾙﾀﾞｱﾄﾞﾚｽ
Private msFileAddress As String     '対象ﾌｧｲﾙｱﾄﾞﾚｽ
Private msDirAddress As String      '無効ﾎﾙﾀﾞｱﾄﾞﾚｽ
Private mvItemMode As Variant       '出力項目 (0：ﾎﾙﾀﾞ+ﾌｧｲﾙ 1:ﾎﾙﾀﾞ 2：ﾌｧｲﾙ)
Private msFileType As String        'ﾌｧｲﾙﾀｲﾌﾟ (空白は全てが対象)
Private msNonType As String        '無効ﾌｧｲﾙﾀｲﾌﾟ (空白は全てが対象)
Private mbSubfCover As Boolean      'ｻﾌﾞﾎﾙﾀﾞ検索対象 (True:行う False:行わない)
Private mbStartFlag As Boolean      '期間開始日有効
Private mbEndFlag As Boolean        '期間終了日有効
Private mvSubfNames As Variant      'ｻﾌﾞﾎﾙﾀﾞ
Private mFileNames As Variant       '対象ﾌｧｲﾙ
Private mDirNames As Variant        '無効ﾎﾙﾀﾞ
Private moFiles As Collection       'ﾌｧｲﾙ格納ｺﾚｸｼｮﾝ
'           初期化
Private Sub Class_Initialize()
    msPath = ThisWorkbook.Path
    mvStartDate = ""
    mbStartFlag = False
    mvEndDate = ""
    mbEndFlag = False
    msCondSheet = CMENU
    msSubfAddress = ""
    msFileAddress = ""
    msDirAddress = ""
    mvItemMode = 0
    msFileType = ""
    msNonType = ""
    mbSubfCover = True
    Set moFiles = New Collection
End Sub
'           後処理
Private Sub Class_Terminate()
    If Not moFiles Is Nothing Then
        If moFiles.Count > 0 Then
            Dim i
            For i = 1 To moFiles.Count
                moFiles.Remove 1
            Next i
        End If
        Set moFiles = Nothing
    End If
End Sub
'           検索対象ﾊﾟｽ
Public Property Get Path() As String
    Path = msPath
End Property
Public Property Let Path(ByVal vNewValue As String)
    msPath = vNewValue
    If Right(msPath, 1) <> Application.PathSeparator Then
        msPath = msPath & Application.PathSeparator
    End If
End Property
'           ﾌｧｲﾙｺﾚｸｼｮﾝ
Public Property Get Files() As Collection
    Set Files = moFiles
End Property
'           ﾌｧｲﾙの検索
Public Sub ExecSearch()
    On Error GoTo errExecSearch
    
    Dim oFSO As New FileSystemObject
    Dim oFolder As Folder
    Dim R As Boolean
    
    If IsEmpty(mvSubfNames(1)) = True Then
        Set oFolder = oFSO.GetFolder(msPath)
        R = FileSearch(oFolder)
    Else
        If mbSubfCover = False Then Exit Sub    'ｻﾌﾞﾎﾙﾀﾞ検索対象でない
        Dim vSubf
        For Each vSubf In mvSubfNames
            Set oFolder = oFSO.GetFolder(msPath)
            Dim oSubFolders As Folders
            Dim oSubFolder As Folder
            Set oSubFolders = oFolder.SubFolders
            If oSubFolders.Count = 0 Then
                Exit Sub
            End If
            For Each oSubFolder In oSubFolders
                With oSubFolder
                    If InStr(UCase(.Name), UCase(vSubf)) <> 0 Then
                        R = FileSearch(oSubFolder)
                    End If
                End With
            Next
        Next
    End If
    Exit Sub
errExecSearch:
    MsgBox Err.Description
End Sub
'       ﾌｧｲﾙ検索
'       oFolder     -   ﾃﾞｨﾚｸﾄﾘ
'       戻り値      -   True: 下位ﾃﾞｨﾚｸﾄﾘ無 False：下位ﾃﾞｨﾚｸﾄﾘ有
Private Function FileSearch(oFolder As Folder) As Boolean
    FileSearch = False
    If mvItemMode <> 1 Then     '1:ﾎﾙﾀﾞのみは行わない
        Dim oFiles As Files
        Dim oFile As File
        Set oFiles = oFolder.Files
        For Each oFile In oFiles
            With oFile
                If IsFileName(.Name) = True Then
                    If IsTermDate(.DateLastModified) = True Then
                        moFiles.Add oFile       'ﾌｧｲﾙの格納
                    End If
                End If
            End With
        Next
    End If
    Dim oSubFolders As Folders
    Dim oSubFolder As Folder
    Set oSubFolders = oFolder.SubFolders
    If oSubFolders.Count = 0 Then
        FileSearch = True
        Exit Function
    End If
    For Each oSubFolder In oSubFolders
        With oSubFolder
            If IsDirName(.Name) = False Then
                If mvItemMode = 0 Or mvItemMode = 1 Then
                    moFiles.Add oSubFolder      'ﾃﾞｨﾚｸﾄﾘの格納
                End If
                If mbSubfCover = True Then  'ｻﾌﾞﾎﾙﾀﾞ検索対象
                    Dim R As Boolean
                    R = FileSearch(oSubFolder)
                End If
            End If
        End With
    Next
End Function
'       検索対象ﾌｧｲﾙﾁｪｯｸ
'       SearchName  -   ﾌｧｲﾙ名
'       戻り値      -   True: 検索対象ﾌｧｲﾙ False：対象外
Private Function IsFileName(SearchName) As Boolean
    IsFileName = False
    Dim vFt
    If msFileType <> "" Then            'ﾌｧｲﾙﾀｲﾌﾟのﾁｪｯｸ
        If InStr(SearchName, ".") <> 0 Then
            vFt = Split(SearchName, ".")
            If InStr(UCase(msFileType), UCase(vFt(UBound(vFt)))) = 0 Then
                Exit Function
            End If
        Else
            Exit Function
        End If
    End If
    If msNonType <> "" Then            '無効ﾌｧｲﾙﾀｲﾌﾟのﾁｪｯｸ
        If InStr(SearchName, ".") <> 0 Then
            vFt = Split(SearchName, ".")
            If InStr(UCase(msNonType), UCase(vFt(UBound(vFt)))) <> 0 Then
                Exit Function
            End If
        End If
    End If
     If IsEmpty(mFileNames(1)) = True Then
        IsFileName = True
        Exit Function
    End If
    Dim FileName
    For Each FileName In mFileNames
        If InStr(FileName, "/") = 0 Then
            If InStr(StrConv(SearchName, vbWide), StrConv(FileName, vbWide)) <> 0 Then
                IsFileName = True
                Exit For
            End If
        Else
            Dim vFbuf
            vFbuf = Split(FileName, "/")
            Dim i
            Dim bF
            bF = True
            For i = 0 To UBound(vFbuf)
                If InStr(StrConv(SearchName, vbWide), StrConv(Trim(vFbuf(i)), vbWide)) = 0 Then
                    bF = False
                    Exit For
                End If
            Next
            If bF = True Then
                IsFileName = True
                Exit For
            End If
        End If
    Next
End Function
'       検索対象外ﾃﾞｨﾚｸﾄﾘﾙﾁｪｯｸ
'       SearchName  -   ﾃﾞｨﾚｸﾄﾘ名
'       戻り値      -   True: 検索対象外ﾃﾞｨﾚｸﾄﾘ False：対象
Private Function IsDirName(SearchName) As Boolean
    IsDirName = False
    If IsEmpty(mDirNames(1)) = True Then Exit Function
    Dim FileName
    For Each FileName In mDirNames
        If FileName = SearchName Then
            IsDirName = True
            Exit For
        End If
    Next
End Function
'       検索対象期間ﾁｪｯｸ
'       vFileDate   -   ﾌｧｲﾙの更新日付
'       戻り値      -   True: 検索対象ﾌｧｲﾙ False：対象外
Private Function IsTermDate(vFileDate) As Boolean
    IsTermDate = False
    If mbStartFlag = True Then
        If DateDiff("d", mvStartDate, vFileDate) < 0 Then Exit Function
    End If
    If mbEndFlag = True Then
        If DateDiff("d", mvEndDate, vFileDate) > 0 Then Exit Function
    End If
    IsTermDate = True
End Function

ファイル読込

File欄の「□」釦を押下すると、選択しているセルのファイルが開きます。ファイルがEXCELの場合は、読取専用で開きます。EXCEL以外の時は、選択ファイルのファイルタイプに応じて、登録されているアプリケーションでファイルを開きます。

□釦には「ファイル読込」マクロが登録されています。

'       ファイル読込
Public Sub ファイル読込()
    Dim vFullPath
    Dim vFilename
    vFullPath = Cells(ActiveCell.Row, 6).Text
    If vFullPath = "" Then Exit Sub
    vFilename = Cells(ActiveCell.Row, 3).Text
    
    Dim vBuf
    vBuf = Split(vFilename, ".")
    Dim vFileType
    vFileType = Trim(LCase(vBuf(UBound(vBuf))))
    
    Dim vPath
    vPath = Replace(vFullPath, vFilename, "")
    If InStr(vPath, ":") = 0 And InStr(vPath, Application.PathSeparator & Application.PathSeparator) = 0 Then
        vPath = ThisWorkbook.Path & Application.PathSeparator & vPath
    End If
    
    If InStr(vFileType, "xls") <> 0 Then                    'EXCEL
        Workbooks.Open FileName:=vPath & vFilename, ReadOnly:=True
        Exit Sub
    End If
    If vFileType = "doc" Then                           'Word
        Dim wdApp As Word.Application
        Set wdApp = CreateObject("Word.Application")
        wdApp.Visible = True
        wdApp.Documents.Open FileName:=vPath & vFilename, ReadOnly:=True
        Exit Sub
    Else
        Dim Ret
        With CreateObject("Wscript.Shell")
            Ret = .Run("""" & vPath & vFilename & """", 5)
        End With
    End If
End Sub