HOME > エクセルVBA > サンプル > PathName

PathName


【ファイル名】PathName.xlsm
【バージョン】Ver 1.0.1.1
【作成日】2015年02月13日
【更新日】2017年02月15日
【動作確認】Windows 7
【必要なソフト】Microsoft Excel 2010
【ダウンロード】PathName.zip
【説明】パス名からファイル名や拡張子を取得するなどします。

VBAで作成しました。WSHやWindows APIの関数は使用してません。
パス名は文字列として処理しますので、実際に存在してなくてかまいません。
VBAPathModule
' VBAPathModule
Option Explicit
' パス名に拡張子があるか?
Public Function IsExt(PathName As String) As Boolean
  Dim dot As Long
  Dim yen As Long
  Dim l As Long

  dot = InStrRev(PathName, ".", Compare:=vbBinaryCompare)
  yen = InStrRev(PathName, Application.PathSeparator, Compare:=vbBinaryCompare)
  l = Len(PathName)
  IsExt = (dot > yen) And (dot <> l) ' .は\よりも右、.は最後ではいけません!
  ' ..\temp = False
  ' test.   = False
  ' .txt    = True
End Function
' パス名から拡張子を取得します。(ドット「.」を含みます。)拡張子がない場合はvbNullString
Public Function GetExt(PathName As String) As String
  Dim dot As Long

  If IsExt(PathName) = False Then
    GetExt = vbNullString
    Exit Function
  End If

  dot = InStrRev(PathName, ".", Compare:=vbBinaryCompare)
  GetExt = Mid(PathName, dot)
End Function
' パス名からパスを除いて、ファイル名を取得します。ファイル名がない場合はvbNullString
Public Function GetFileName(PathName As String) As String
  Dim yen As Long
  Dim l As Long

  GetFileName = vbNullString
  yen = InStrRev(PathName, Application.PathSeparator, Compare:=vbBinaryCompare)
  l = Len(PathName)

  If PathName = "." Then Exit Function
  If PathName = ".." Then Exit Function
  If (l = 2) And (InStr(1, PathName, ":", vbBinaryCompare) = 2) Then Exit Function ' ドライブのみ
  If yen < 1 Then
    GetFileName = PathName
  Else
    If l > yen Then GetFileName = Mid$(PathName, yen + 1)
  End If
End Function
' パス名からファイル名を除いて、パスを取得します。(最後に「\」はつきません。コロン「:」がなくかつ円記号「\」がない場合はファイルとします)
Public Function GetPathName(PathName As String) As String
  Dim yen As Long
  Dim l As Long
  Dim colon As Long

  yen = InStrRev(PathName, Application.PathSeparator, Compare:=vbBinaryCompare)
  colon = InStrRev(PathName, ":", Compare:=vbBinaryCompare)
  l = Len(PathName)

  GetPathName = PathName
  If PathName = "." Then Exit Function
  If PathName = ".." Then Exit Function

  If yen > 0 Then
    GetPathName = Left$(PathName, yen - 1)
  ElseIf colon > 0 Then
    GetPathName = PathName ' ドライブ
  Else
    GetPathName = vbNullString ' 円記号「\」がない場合はファイルとします
  End If
End Function
' パス名の最後に「\」を付けます。(最後が既に「\」の場合は付けません)【注意】パスが拡張子のないファイル名の場合も「\」を付けます。
Public Function AddBackSlash(PathName As String) As String
  Dim yen As Long
  Dim dot As Long
  Dim l As Long

  AddBackSlash = PathName
  yen = InStrRev(PathName, Application.PathSeparator, Compare:=vbBinaryCompare)
  dot = InStrRev(PathName, ".", Compare:=vbBinaryCompare)
  l = Len(PathName)

  If yen = l Then Exit Function ' 最後が既に「\」
  If (l > 2) And (dot = l) Then Exit Function ' 3文字以上でかつ最後が「.」

  If IsExt(PathName) = False Then
    AddBackSlash = PathName & Application.PathSeparator
  End If
End Function
' パス名の最後の「\」を削除します。
Public Function RemoveBackSlash(PathName As String) As String
  Dim yen As Long
  Dim l As Long

  yen = InStrRev(PathName, Application.PathSeparator, Compare:=vbBinaryCompare)
  l = Len(PathName)

  If l < 1 Then
    RemoveBackSlash = vbNullString
  ElseIf yen = l Then
    RemoveBackSlash = Left$(PathName, yen - 1)
  Else
    RemoveBackSlash = PathName
  End If
End Function
' パス名からドライブ名を取得します。(2文字目がコロン「:」かを判断します。)
Public Function GetDriveName(PathName As String) As String
  Dim colon As Long

  colon = InStr(1, PathName, ":", vbBinaryCompare)
  If colon = 2 Then
    GetDriveName = Left$(PathName, 2)
  Else
    GetDriveName = vbNullString
  End If
End Function
' パス名の拡張子を削除します。
Public Function RemoveExt(パス名 As String) As String
  Dim dot As Long
  Dim l As Long

  dot = InStrRev(パス名, ".", Compare:=vbBinaryCompare)
  l = Len(パス名)
  RemoveExt = パス名
  If IsExt(パス名) Then ' 拡張子がある場合は

    If (l = dot) And (l > 2) And (Mid$(パス名, l - 1, 1) <> ".") Then ' 最後がドット「.」でかつ最後から2文字目がドット「.」以外
      RemoveExt = Left$(パス名, l - 1) ' 最後のドット「.」を削除します。
    Else
      RemoveExt = Left$(パス名, dot - 1)
    End If

  End If
End Function
' パス名の拡張子を変更します。(拡張子にドット「.」を含みます)
Public Function ChangeFileExt(PathName As String, ExtName As String) As String
  Dim dot As Long
  Dim yen As Long
  Dim colon As Long
  Dim l As Long
  Dim ext As String

  dot = InStrRev(PathName, ".", Compare:=vbBinaryCompare)
  yen = InStrRev(PathName, Application.PathSeparator, Compare:=vbBinaryCompare)
  colon = InStrRev(PathName, ":", Compare:=vbBinaryCompare)
  l = Len(PathName)

  ' 拡張子を削除します。
  If (Len(ExtName) < 1) Or ExtName = "." Then
    ChangeFileExt = RemoveExt(PathName)
    Exit Function
  End If

  ext = ExtName
  If InStrRev(ExtName, ".", Compare:=vbBinaryCompare) < 1 Then
    ext = ChangeFileExt & "." & ExtName ' 新しい拡張子にドット「.」がない場合は追加します。
  End If

  If IsExt(PathName) Then ' 拡張子がある場合は
    ChangeFileExt = RemoveExt(PathName) & ext ' 拡張子を変更します。
  Else
    If (dot = l) Or (yen = l) Or (colon = l) Then  ' 空かドライブか最後がディレクトリ
      ChangeFileExt = PathName ' 何もしない
    Else ' ファイル
      ChangeFileExt = PathName & ext ' 拡張子を追加します。
    End If
  End If
End Function
' 指定した左側の連続する文字を削除します。
Public Function DelLeft(対象文字列 As String, Optional 削除する文字 As String = """", Optional 比較方法 As VbCompareMethod = vbBinaryCompare) As String
  Dim i As Long, l As Long, p As Long, DelLength As Long, Count As Long

  l = Len(対象文字列)
  DelLength = Len(削除する文字)
    DelLeft = 対象文字列
  If (l < 1) Or (DelLength < 1) Then ' 削除できない場合は終了します。
    Exit Function
  End If

  Count = 0
  i = 1
  Do While (i <= l)
    p = InStr(i, 対象文字列, 削除する文字, 比較方法)
    If p <> i Then
      Exit Do
    Else
      Count = Count + 1
      i = i + DelLength
    End If
  Loop

  If Count > 0 Then ' 削除する文字があった場合は
    If (Count * DelLength) < l Then
      DelLeft = Mid$(対象文字列, Count * DelLength + 1) ' 左側を削除します。
    Else
      DelLeft = vbNullString ' すべて削除します。
    End If
  End If
End Function
' 指定した右側の連続する文字を削除します。
Public Function DelRight(対象文字列 As String, Optional 削除する文字 As String = """", Optional 比較方法 As VbCompareMethod = vbBinaryCompare) As String
  Dim i As Long, l As Long, p As Long, DelLength As Long, Count As Long

  l = Len(対象文字列)
  DelLength = Len(削除する文字)
  DelRight = 対象文字列
  If (l < 1) Or (DelLength < 1) Then ' 削除できない場合は終了します。
    Exit Function
  End If

  Count = 0
  i = l
  Do While (i > 0)
    p = InStrRev(対象文字列, 削除する文字, i, Compare:=比較方法)
    If p < 1 Then Exit Do ' ない場合
    If p <> (i - DelLength + 1) Then ' あっても既に違う文字が出た
      Exit Do
    Else ' 連続した削除する文字
      Count = Count + 1
      i = i - DelLength
    End If
  Loop

  If Count > 0 Then ' 削除する文字があった場合は
    If (Count * DelLength) < l Then
      DelRight = Left$(対象文字列, l - (Count * DelLength)) ' 左側を削除します。
    Else
      DelRight = vbNullString ' すべて削除します。
    End If
  End If
End Function
' 左側と右側の連続する二重引用符「"」を削除します。その後で二重引用符「"」で囲みます。(途中に含まれる二重引用符は変更しません)
Public Function QuoteSpaces(PathName As String) As String
  QuoteSpaces = """" & UnquoteSpaces(PathName) & """"
End Function
' 左側と右側の連続する二重引用符「"」を削除します。
Public Function UnquoteSpaces(PathName As String) As String
  UnquoteSpaces = DelLeft(DelRight(PathName))
End Function

このページの上