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

WindowsAPIPath


【ファイル名】WindowsAPIPath.xlsm
【バージョン】Ver 1.0.0.2
【作成日】2019年04月24日
【更新日】2021年04月22日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】WindowsAPIPath.zip
【説明】Windows APIでパス名からディレクトリ名、ファイル名を取得するサンプルなどです。
パス名の関数の戻り値は引数によっては、予想と違う値を返す場合があります。

PathFindExtension・・・パス名からドット「.」を含む拡張子を取得します。
パス名 結果
c:\work\a\test.txt .txt
c:\work\a\test
c:\work\a\test.txt.bmp .bmp
test.jpg E
.doc .doc
. .

PathUnquoteSpaces・・・パス名の二重引用符「"」を削除して返します。(単純に最初と最後の二重引用符を削除します。)
パス名 結果
"c:\work\a\test.txt" c:\work\a\test.txt
c:\work\a\test.bmp c:\work\a\test.bmp
""c:\work\a\test.txt"" "c:\work\a\test.txt"

PathQuoteSpaces・・・空白を含むパス名を二重引用符「"」で囲んで返します。(空白を含まない場合は囲みません)
パス名 結果
c:\Program Files\a\test.exe "c:\Program Files\a\test.exe"
c:\work\a\test.bmp c:\work\a\test.bmp
"c:\Program Files\a\test.exe" ""c:\Program Files\a\test.exe""

PathAddBackslash・・・パスの最後に「\」を付けます。(最後が既に「\」の場合は付けません)【注意】パスがファイル名の場合も「\」を付けます。
パス名 結果
c:\work c:\work\
c: c:\
c:\work\a\test.txt c:\work\a\test.txt\
c:\work\a\ c:\work\a\

PathRemoveBackslash・・・パスの最後の「\」を削除します。
パス名 結果
c:\work\ c:\work
c:\ c:\
\ \
..\ ..

PathRemoveFileSpec・・・指定したパス名からパスのみ取得します。
パス名 結果
c:\work\a\test.txt c:\work\a
c:\work\a\test c:\work\a
c:\work\a\ c:\work\a
c: c:
\ \
test.txt

PathStripPath・・・指定したパス名からパスを除きファイル名のみ取得します。(パス名にファイル名がない場合は問題です。)
パス名 結果
c:\work\a\test.txt test.txt
c:\work\a\test test
c:\work\ work\
c:\ c:\

PathRenameExtension・・・指定した拡張子に変更したファイル名を取得します。(拡張子はドット「.」を含みます。)
パス名 拡張子 結果
c:\work\a\test.txt .jpg c:\work\a\test.jpg
c:\work\a\test.txt c:\work\a\test
c:\work\a\test.txt xml c:\work\a\test.xml
test.jpg .doc test.doc
c:\work\ .csv c:\work\.csv
c: .html c:.html

WindowsAPIPathModule
' WindowsAPIPathModule
Option Explicit
Option Base 1
Option Compare Binary

Public Const MAX_PATH As Long = 260& ' windef.h

' コンパイラ定数(Win16, Win32, Win64, MAC, Vba6, Vba7)
' https://msdn.microsoft.com/ja-jp/library/gg264614.aspx
#If Win64 Then ' 64ビット
  ' https://msdn.microsoft.com/en-us/library/windows/desktop/aa366788(v=vs.85).aspx
  Declare PtrSafe Sub CopyMemoryByte Lib "kernel32" Alias "RtlMoveMemory" (Destination As Byte, ByVal Source As LongPtr, ByVal Length As LongPtr)
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shlwapi/nf-shlwapi-pathaddbackslashw
  Declare PtrSafe Function PathAddBackslash Lib "SHLWAPI.DLL" Alias "PathAddBackslashW" (ByVal PahtName As LongPtr) As LongPtr ' 戻り値はNULLのポインター
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shlwapi/nf-shlwapi-pathfindextensionw
  Declare PtrSafe Function PathFindExtension Lib "SHLWAPI.DLL" Alias "PathFindExtensionW" (ByVal PahtName As LongPtr) As LongPtr
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shlwapi/nf-shlwapi-pathquotespacesw
  Declare PtrSafe Function PathQuoteSpaces Lib "SHLWAPI.DLL" Alias "PathQuoteSpacesW" (ByVal PahtName As LongPtr) As Long
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shlwapi/nf-shlwapi-pathremovebackslashw
  Declare PtrSafe Function PathRemoveBackslash Lib "SHLWAPI.DLL" Alias "PathRemoveBackslashW" (ByVal PahtName As LongPtr) As LongPtr
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shlwapi/nf-shlwapi-pathremovefilespecw
  Declare PtrSafe Function PathRemoveFileSpec Lib "SHLWAPI.DLL" Alias "PathRemoveFileSpecW" (ByVal PahtName As LongPtr) As Long
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shlwapi/nf-shlwapi-pathrenameextensionw
  Declare PtrSafe Function PathRenameExtension Lib "SHLWAPI.DLL" Alias "PathRenameExtensionW" (ByVal PahtName As LongPtr, ByVal ExtName As LongPtr) As Long
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shlwapi/nf-shlwapi-pathstrippathw
  Declare PtrSafe Sub PathStripPath Lib "SHLWAPI.DLL" Alias "PathStripPathW" (ByVal PahtName As LongPtr)
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shlwapi/nf-shlwapi-pathunquotespacesw
  Declare PtrSafe Sub PathUnquoteSpaces Lib "SHLWAPI.DLL" Alias "PathUnquoteSpacesW" (ByVal PahtName As LongPtr)
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shlwapi/nf-shlwapi-pathisdirectoryemptyw
  Declare PtrSafe Function PathIsDirectoryEmpty Lib "SHLWAPI.DLL" Alias "PathIsDirectoryEmptyW" (ByVal pszPath As LongPtr) As Long
#Else
  Declare Sub CopyMemoryByte Lib "kernel32" Alias "RtlMoveMemory" (Destination As Byte, ByVal Source As Long, ByVal Length As Long)
  Declare Function PathAddBackslash Lib "SHLWAPI.DLL" Alias "PathAddBackslashW" (ByVal PahtName As Long) As Long
  Declare Function PathFindExtension Lib "SHLWAPI.DLL" Alias "PathFindExtensionW" (ByVal PahtName As Long) As Long
  Declare Function PathQuoteSpaces Lib "SHLWAPI.DLL" Alias "PathQuoteSpacesW" (ByVal PahtName As Long) As Long
  Declare Function PathRemoveBackslash Lib "SHLWAPI.DLL" Alias "PathRemoveBackslashW" (ByVal PahtName As Long) As Long
  Declare Function PathRemoveFileSpec Lib "SHLWAPI.DLL" Alias "PathRemoveFileSpecW" (ByVal PahtName As Long) As Long
  Declare Function PathRenameExtension Lib "SHLWAPI.DLL" Alias "PathRenameExtensionW" (ByVal PahtName As Long, ByVal ExtName As Long) As Long
  Declare Sub PathStripPath Lib "SHLWAPI.DLL" Alias "PathStripPathW" (ByVal PahtName As Long)
  Declare Sub PathUnquoteSpaces Lib "SHLWAPI.DLL" Alias "PathUnquoteSpacesW" (ByVal PahtName As Long)
  Declare Function PathIsDirectoryEmpty Lib "SHLWAPI.DLL" Alias "PathIsDirectoryEmptyW" (ByVal pszPath As Long) As Long
#End If

#If Win64 Then
  Private ret As LongPtr
#Else
  Private ret As Long
#End If

' 指定した数になるようにvbNullCharを追加します。
Public Function AddNull(ByVal PathName As String, Length As Long) As String
  AddNull = PathName & String$(Length - Len(PathName), vbNullChar)
End Function
' 指定したヌルで終わる文字列から、vbNullCharの左側の文字列を取得します。
Public Function StrVBA(ByVal EndNullString As String) As String
  Dim p As Long
  
  p = InStr(1, EndNullString, vbNullChar)
  If p > 0 Then
    StrVBA = Left(EndNullString, p - 1)
  Else
    StrVBA = EndNullString ' ■ vbNullCharがない場合は引数をそのまま返します。
'    StrVBA = vbNullString ' ■ 必要に応じて変更してください。
  End If
End Function
' ヌルで終わる文字列のポインターから、指定した長さのVBAの文字列を取得します。
#If Win64 Then ' 64ビット
Public Function StrFromPtr(ByVal strPointer As LongPtr, ByVal Length As Long) As String
  ReDim BufArray(1 To Length) As Byte
  
  CopyMemoryByte BufArray(1), strPointer, CLngLng(Length)
  StrFromPtr = StrVBA(BufArray())
End Function
#Else
Public Function StrFromPtr(ByVal strPointer As Long, ByVal Length As Long) As String
  ReDim BufArray(1 To Length) As Byte
  
  CopyMemoryByte BufArray(1), strPointer, Length
  StrFromPtr = StrVBA(BufArray())
End Function
#End If
' パス名からドット「.」を含む拡張子を取得します。
Public Function FindExtension(ByVal PathName As String) As String
  ret = PathFindExtension(StrPtr(PathName))

  If ret <> 0 Then
    FindExtension = StrFromPtr(ret, MAX_PATH * 2)
  Else
    FindExtension = vbNullString
  End If
End Function
' パス名の二重引用符「"」を削除して返します。(単純に最初と最後の二重引用符を削除します。)
Public Function PathUnquote(ByVal PathName As String) As String
  Dim str As String
   
  Err.Clear
  str = AddNull(PathName, MAX_PATH)
  PathUnquoteSpaces StrPtr(str)
  If Err.LastDllError > 0 Then
    PathUnquote = PathName
  Else
    PathUnquote = StrVBA(str)
  End If
End Function
' 空白を含むパス名を二重引用符「"」で囲んで返します。(単純に二重引用符で囲むだけです。)
'【注意】パス名に空白がない場合は何もしません!
Public Function PathQuote(ByVal PathName As String) As String
  Dim str As String
   
  str = AddNull(PathName, MAX_PATH)
  ret = PathQuoteSpaces(StrPtr(str))
  If ret <> 0 Then
    PathQuote = StrVBA(str)
  Else
    PathQuote = PathName
  End If
End Function
' パスの最後の「\」を削除します。(「c:\」などのドライブのカレントは削除しません。パスが「\」のみは削除しません。)
Public Function RemoveBackSlash(ByVal PathName As String) As String
  Dim str As String
  
  Err.Clear
  str = AddNull(PathName, MAX_PATH)
  ret = PathRemoveBackslash(StrPtr(str))
  If ret <> 0 Then
    RemoveBackSlash = StrVBA(str)
  Else
    RemoveBackSlash = PathName
  End If
End Function
' パスの最後に「\」を付けます。(最後が既に「\」の場合は付けません)【注意】パスがファイル名の場合も「\」を付けます。
Public Function AddBackSlash(ByVal PathName As String) As String
  Dim str As String
  
  str = AddNull(PathName, MAX_PATH)
  ret = PathAddBackslash(StrPtr(str))
  If ret <> 0 Then
    AddBackSlash = StrVBA(str)
  Else
    AddBackSlash = vbNullString
  End If
End Function
' 指定したパス名からパスのみ取得します。
Public Function RemoveFileSpec(ByVal PathName As String) As String
  
  ret = PathRemoveFileSpec(StrPtr(PathName))
  If ret <> 0 Then
    RemoveFileSpec = StrVBA(PathName)
  Else
    RemoveFileSpec = PathName ' ファイル名がないので何もしない
  End If
End Function
' 指定したパス名からパスを除きファイル名のみ取得します。
'【注意】パス名にファイル名がない場合は、パスを返すので問題です!
Public Function GetFileName(ByVal PathName As String) As String
  Dim str As String
  
  Err.Clear
  str = AddNull(PathName, MAX_PATH)
  Call PathStripPath(StrPtr(str))
  If Err.LastDllError > 0 Then
    GetFileName = PathName
  Else
    GetFileName = StrVBA(str)
  End If
End Function
' 指定した拡張子に変更したファイル名を取得します。(拡張子はドット「.」を含みます。)
Public Function RenameExtension(ByVal PathName As String, ByVal ExtName As String) As String
  Dim NewName As String
  
  NewName = AddNull(PathName, MAX_PATH)
  If (Len(ExtName) > 0) And (InStr(1, ExtName, ".", vbBinaryCompare) < 1) Then ExtName = "." & ExtName ' ドット「.」がない場合は付けます。
  ret = PathRenameExtension(StrPtr(NewName), StrPtr(ExtName))
  If ret <> 0 Then
    RenameExtension = StrVBA(NewName)
  Else
    RenameExtension = vbNullString
  End If
End Function
' 入力した10進数を2進数で表示します。
' Dec2Bin(10進の整数, 桁数)・・・10進数を2進数に変換します。(負の数は2の補数。桁数を指定すると先頭に0を表示できます)
' https://support.office.com/ja-jp/article/DEC2BIN-%E9%96%A2%E6%95%B0-d64fbb1f-5602-49c9-be38-4a9db6e406b6
Sub Msgbox_Dec2Bin(Optional ByVal 数値 As Variant)
Dim strNum As Variant

If IsMissing(数値) Then ' 引数を省略した場合は
  strNum = Application.InputBox(Prompt:="10進数:", Title:="10進数 --> 2進数", Type:=1) ' Type:=1は数値の入力
  If TypeName(strNum) = "Boolean" Then Exit Sub ' [キャンセル]ボタンを押した
Else
  If TypeName(数値) = "String" Then
    strNum = Val(数値)
  Else
    strNum = 数値
  End If
End If
MsgBox Prompt:=strNum & " --> " & Application.WorksheetFunction.Dec2Bin(strNum), Buttons:=vbInformation, Title:="10進数 --> 2進数"
'Debug.Print strNum & " --> " & Application.WorksheetFunction.Dec2Bin(strNum)
End Sub
' フォルダが空か調べます。
' 引数:FolderName・・・フォルダ名
' 戻り値:True=空、False=空ではありません。
Public Function IsDirectoryEmpty(ByVal FolderName As String) As Boolean
  Dim str As String
   
  str = AddNull(FolderName, MAX_PATH)
  IsDirectoryEmpty = (PathIsDirectoryEmpty(StrPtr(str)) <> 0)
End Function

このページの上