トップ　>　備忘録　>　ファイルのベース名・拡張子の取得

'-----------------------------------------------------------------
' ファイルのベース名・拡張子の取得・表示
'-----------------------------------------------------------------
'
'［作成日］2012.09.27　［更新日］2024.11.28
' https://excel.syogyoumujou.com/memorandum/get_extension.html
'-----------------------------------------------------------------
Sub ファイルのベース名と拡張子を取得表示()

    '---------------------------------------
    ' ファイル選択
    '---------------------------------------
    Dim varFilePath As Variant
    '《ファイル選択ダイアログボックス》
    ' ・ 引数1：ファイルフィルター
    ' ・ 引数2：ファイルインデックス（既定で表示するフィルター文字列の指定）
    ' ・ 引数3：ダイアログボックスタイトル（既定："ファイルを開く"）
    ' ・ 引数4：ボタンテキスト（Macintosh用）
    ' ・ 引数5：複数選択の設定（True：複数選択可　False：複数選択不可）
    varFilePath = Application.GetOpenFilename("すべてのファイル,*.*", _
                                              , _
                                              "ファイルを選択してください", _
                                              , _
                                              False)
    
    '［キャンセル］ボタンをクリックした場合は抜ける
    If VarType(varFilePath) = vbBoolean Then Exit Sub
    
    ' ファイルを複数選択の場合は最初のファイルパスを対象とする
    If IsArray(varFilePath) Then varFilePath = varFilePath(LBound(varFilePath))

    '---------------------------------------
    ' ファイルベース名取得
    '---------------------------------------
    Dim strBaseName As String
    strBaseName = CreateObject("Scripting.FileSystemObject").GetBaseName(varFilePath)

    '---------------------------------------
    ' 拡張子取得
    '---------------------------------------
    Dim strExtention As String
    strExtention = CreateObject("Scripting.FileSystemObject").GetExtensionName(varFilePath)
    
    '---------------------------------------
    ' 結果表示
    '---------------------------------------
    MsgBox "ファイルベース名：" & strBaseName & vbLf & _
           "拡張子：" & strExtention
End Sub

'-----------------------------------------------------------------
' 列挙型  ※ 列挙型は標準モジュールの宣言セクションに記載します
'-----------------------------------------------------------------
' 情報の種類
Enum TypeOfInfomation
    ドライブ名
    親フォルダ名
    ファイル名
    ベース名
    拡張子
End Enum

'-----------------------------------------------------------------
' ファイルフルパスから情報取得
'-----------------------------------------------------------------
'［引数］
'   FileFullPath：ファイルフルパス
'   TypeOfInfo  ：情報の種類
'［戻り値］
'   成功    ：引数に対応した文字列
'   失敗    ：空の文字列
'［作成日］2012.09.27　［更新日］2024.11.28
' https://excel.syogyoumujou.com/memorandum/get_extension.html
'-----------------------------------------------------------------
Function getInfomationFromFilePath(ByVal FileFullPath As String, _
                                   ByVal TypeOfInfo As TypeOfInfomation) As String
    With CreateObject("Scripting.FileSystemObject")
        Select Case TypeOfInfo
            Case ドライブ名
                getInfomationFromFilePath = .GetDriveName(FileFullPath)
            Case 親フォルダ名
                getInfomationFromFilePath = .GetParentFolderName(FileFullPath)
            Case ファイル名
                getInfomationFromFilePath = .GetFileName(FileFullPath)
            Case ベース名
                getInfomationFromFilePath = .GetBaseName(FileFullPath)
            Case 拡張子
                getInfomationFromFilePath = .GetExtensionName(FileFullPath)
        End Select
    End With
End Function

'-----------------------------------------------------------------
' ファイルフルパスから情報取得関数の使用例
'-----------------------------------------------------------------
Sub 指定フォルダ内のファイルのベース名と拡張子の一覧作成()
    '--------------------------------
    ' フォルダの選択
    '--------------------------------
    Dim strFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "対象フォルダを選択してください"
        If .Show = True Then strFolderPath = .SelectedItems(1)
    End With
    If Len(strFolderPath) = 0 Then Exit Sub

    '--------------------------------
    ' フォルダの存在確認
    '--------------------------------
    If Dir(strFolderPath, vbDirectory) = "" Then
        MsgBox "対象のフォルダが見つかりません", vbExclamation, "終了します"
        Exit Sub
    End If

    '--------------------------------
    ' フォルダ内ファイルを検索
    '--------------------------------
    Dim strFileName As String
    strFolderPath = strFolderPath & Application.PathSeparator ' フォルダパスに区切り文字追加
    strFileName = Dir(strFolderPath & "*.*")                  ' フォルダからファイルを検索
    If strFileName = "" Then                                  ' ファイルパスを取得できなければ終了
        MsgBox "指定フォルダ内にファイルが見つかりません", vbExclamation, "終了します"
        Exit Sub
    End If

    '--------------------------------
    ' 新規ブックに出力
    '--------------------------------
    Dim shtNew As Worksheet
    Set shtNew = Workbooks.Add.Worksheets(1)
    shtNew.Columns("A:B").NumberFormatLocal = "@"             ' A・B列の表示形式を文字列に設定
    shtNew.Range("A3:B3").Value = Array("ファイルベース名", "拡張子")
    
    Dim lngCount     As Long
    Dim strFullPath  As String
    Dim strBaseName  As String
    Dim strExtension As String
    Do
        ' ファイルフルパス作成
        strFullPath = strFolderPath & strFileName
    
        '《ファイルフルパスから情報取得》
        ' ・ 引数1 ： ファイルのフルパス
        ' ・ 引数2 ： 取得する情報の種類（列挙型 TypeOfInfomation から選択）
        strBaseName = getInfomationFromFilePath(strFullPath, ベース名) ' ベース名取得
        strExtension = getInfomationFromFilePath(strFullPath, 拡張子)  ' 拡張子取得

        ' 新規ブックに出力
        shtNew.Cells(4 + lngCount, "A").Resize(1, 2).Value = Array(strBaseName, strExtension)
        lngCount = lngCount + 1
        
        ' 次のファイルを検索
        strFileName = Dir()
    Loop Until strFileName = ""
    
    shtNew.Columns("A:B").AutoFit
    shtNew.Range("A1:B1").Value = Array("対象フォルダ", Left$(strFolderPath, Len(strFolderPath) - 1))
End Sub