VBA Win32API Win64/32 共用 PathfileExistsA Classモジュールを用いてファイルフォルダの有無を判定する

コード

標準モジュール

Sub Api_PathFileExistsample()
With New API_PathFileExistClass
Debug.Print .Win32APiPathFileExistsA("C:\Users\username\OneDrive\ドキュメント\2010\2010.pdf")
End With
End Sub

Class Module クラスモジュール

今回はclsファイルから抜き出したので上にVersion Begin　Attribute　などの記述がありますが、クラスモジュールの名前を明記するためで、削除してかまいません。
またこのままテキストエディタでファイルを新規作成してコピーし保存後、
API_PathFileExistClass.clsに変えるとクラスモジュールに変わります。

API_PathFileExistClass.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "API_PathFileExistClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
# If VBA7 Then
'パスまたはファイルが存在するか
Private Declare PtrSafe Function PathFileExists Lib "SHLWAPI.DLL" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
# Else
Private Declare Function PathFileExists Lib "SHLWAPI.DLL" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
# End If

Public Function Win32APiPathFileExistsA(strFileName) As Boolean
Win32APiPathFileExistsA = CBool(Abs(PathFileExists(strFileName)) * (-1))
End Function

長所

FSOと異なりファイルやフォルダの区別をしない

1個のクラスモジュール、1個の関数でファイル、フォルダに対応

Win64とWin32の共用化が容易

というか普通がおかしいと思う

Declare FunctionからTrue Falseを取るテクニック

Win32はTrueは1でVBAはマイナス1です。
このため、絶対値にマイナス1を掛けてCboolで真偽に変えます。

Property Getを使った例との対比

FilesizeはFilesystemobjectです

CreateFileを使うとうまくいかないので断念しました。今後の課題です。
しかしこれはファイル、フォルダいずれにも対応しています。

標準モジュール

Sub Api_PathFileExistsample()
With New API_PathFileExistClass
Debug.Print .getPathFileExistsAValue("C:\Users\username\OneDrive\ドキュメント\2010\2010.pdf")
Debug.Print .getPathFileExistsAValue("C:\Users\username\OneDrive\ドキュメント\2010\")
Debug.Print .getPathFileExistsAValue("C:\Users\username\OneDrive\ドキュメント\2010")
End With
End Sub

クラスモジュール

API_PathFileExistClass.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "API_PathFileExistClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
# If VBA7 Then
'パスまたはファイルが存在するか
Private Declare PtrSafe Function PathFileExists Lib "SHLWAPI.DLL" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
# Else
Private Declare Function PathFileExists Lib "SHLWAPI.DLL" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
# End If

Private Function Win32APiPathFileExistsA(strfilename) As Boolean
Win32APiPathFileExistsA = CBool(Abs(PathFileExists(strfilename)) * (-1))
End Function

' accessor
Property Get getPathFileExistsAValue(strfilename) As Boolean
getPathFileExistsAValue = Win32APiPathFileExistsA(strfilename)
End Property

このようにシンプルなので比較が容易

フォルダ名の末尾はバックスラッシュ(円マーク)がついてもつかなくても判定する

末尾を気にする必要がない

FSOよりたぶん早い

クラスモジュールはWith クラス名でインスタンスなしで使える

今回学んだ重要な点はこれで、実は変数の宣言、New命令によるインスタンスの作成なしで使える。このため標準モジュールにはDimがいらない。きわめてシンプルになります。

クラスモジュール化すると、標準モジュールがシンプルなのでコードの可読性が高まる

Declareが上にないので、わかりやすいコードになります。

強化版Class

強化版Classモジュール用のサンプル

GetDiskFreeSpaceExによる2gbを超えるドライブの容量

GetFileAttributeAによるPathFileAttribute、フォルダ、ファイルの属性。特にファイルかフォルダかの判定に使用

Api_SetCuurentDirectory

指定したフォルダをカレントにする

GetWindowsDirectory,GetSytemDirectory,GetTempPath

それぞれWindows,System,Tempのフォルダ名

PathIsDirectory

有効なディレクトリか

PathAddBackslash

Directoryの最後に\を追加する。ついていたら追加しない。
これを作っておくと、フォルダ名の末尾に悩まないし & "" & を書かなくてよい。

strCurrentDirectory

カレントのディレクトリを返す

strFileTitle

フルパスからファイル名（Basename + 拡張子)を取得

ShortPath

ShortPathを作成する。FSOと違って一瞬

Filesize

現在これはFilesystemobjectです。

標準モジュール

Option Explicit

Sub AddSlash()
Dim str As String
Dim WSHR As New IWshRuntimeLibrary.WshShell
Dim PathFileClass As API_PathFileExistClass
Set PathFileClass = New API_PathFileExistClass
On Error Resume Next
With PathFileClass
Debug.Print .getPathFileExistsAValue("F:\usr\GSview\gs9.19")
Debug.Print .DirAddSlash("F:\usr\GSview\gs9.19")
Debug.Print .blEmptyDirectory("F:\usr\GSview\gs9.19 ")
Debug.Print .blPathIsDirectory("F:\usr\GSview\gs9.19 ")
Debug.Print .LogicalDriveType("F:\")
Debug.Print "Pathfileattribute:", .PathFileAttribute("F:\usr\GSview\gs9.19")
Debug.Print .strFileTitle("C:\Windows\calc.exe")
Debug.Print .strFullpath("F:\Firefox Setup Stub 44.0.2.exe")
Debug.Print "Current: " & .strCurrentDirectory
Debug.Print "Short::" & .strShortPath("F:\Firefox Setup Stub 44.0.2.exe")
 Call .Api_SetCuurentDirectory("F:\")
Debug.Print "Current: " & .strCurrentDirectory
Debug.Print "空き容量/2GB以上は誤り" & .lgDiskFreespace("空き容量", "F:\")
Debug.Print "空き容量/2GB以上は誤り" & .lgDiskFreespace("ディスク容量", "F:\")
Debug.Print "空き容量/全容量" & .dblDiskFreeSpaceEx("F:\") & "/" & .dblDiskTotalSpaceEx("F:\")
Debug.Print .strTempPath
Debug.Print .strWindir
Debug.Print .strSysDir
If .DoCreateDir("F:\tai") = True Then
Debug.Print "Directoryできた"
Else
End If

With CreateObject("Wscript.Shell")
Debug.Print "Wsh:", .ExpandEnvironmentStrings("%WinDir%")
End With
Debug.Print .getLogicalDriveList
End With
On Error GoTo 0
If Err.Number <> 0 Then
Debug.Print Err.Number, Err.Description: Err.Clear

Err.Clear
End If
Set PathFileClass = Nothing

End Sub

強化版Classモジュール

20190605更新

APIでファイルサイズが取得できるようになりました

https://tsware.jp/labo/labo_25.htm
こちらのサイトを参考にProperty Get lgFIleSizeAPI(strPath As String) As Long
を作りました

注意

ただしフォルダは0で返ります

FSOを強化

コードを作り直し、ファイルもフォルダも値を返し、エラーは-1が返るようにしました

Option Explicit
Private Const MAX_PATH As Long = 260
'   Cannot create a file when that file already exists.
Private Const ERROR_ALREADY_EXISTS = 183&

'   Define the generic mapping array.  This is used to denote the
'   mapping of each generic access right to a specific access mask.

Private Type GENERIC_MAPPING
        GenericRead As Long
        GenericWrite As Long
        GenericExecute As Long
        GenericAll As Long
End Type
' GetDriveType return values
Const DRIVE_REMOVABLE = 2
Const DRIVE_FIXED = 3
Const DRIVE_REMOTE = 4
Const DRIVE_CDROM = 5
Const DRIVE_RAMDISK = 6

Private Const FILE_TYPE_UNKNOWN = &H0
Private Const FILE_TYPE_DISK = &H1
Private Const FILE_TYPE_CHAR = &H2

Private Const FILE_TYPE_REMOTE = &H8000&

Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const CREATE_NEW = 1
Private Const CREATE_ALWAYS = 2
Private Const OPEN_EXISTING = 3
Private Const OPEN_ALWAYS = 4
Private Const TRUNCATE_EXISTING = 5

Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type


# If VBA7 Then
Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As LongPtr
        bInheritHandle As Long
End Type
Private Type OVERLAPPED
        Internal As LongPtr
        InternalHigh As LongPtr
        offset As Long
        OffsetHigh As Long
        hEvent As LongPtr
End Type
'パスまたはファイルが存在するか
Private Declare PtrSafe Function PathFileExists Lib "SHLWAPI.DLL" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
'指定されたパスが空のディレクトリであるか
Private Declare PtrSafe Function PathIsDirectoryEmpty Lib "SHLWAPI.DLL" Alias "PathIsDirectoryEmptyA" (ByVal pszPath As String) As Boolean
    'pszPath[in]：path名
    'Return     ：空の場合 True、空でなければ False がかえる。
'''''''''''''''''''''''''''''''
Private Declare PtrSafe Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare PtrSafe Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'Private Declare PtrSafe Function SetCurrentDirectory Lib "kernel32" (ByVal lpPathName As Long) As Long
' Set rrent Directory
Private Declare PtrSafe Function SetCurrentDirectory Lib "kernel32" Alias _
                            "SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long
'Private Declare PtrSafe Function SetCurrentDirectory Lib "kernel32.dll" Alias "SetCurrentDirectoryW" (ByVal lpPathName As Long) As Long
'Private Declare PtrSafe Function SetCurrentDirectory Lib "kernel32.dll" Alias "SetCurrentDirectoryA" (ByVal lpPathName As Long) As Long

' Get rrent Directory
'Private Declare PtrSafe Function GetCurrentDirectory Lib "kernel32.dll" Alias "GetCurrentDirectoryW" (ByVal nBufferLength As Long, ByVal lpBuffer As Long) As Long
Private Declare PtrSafe Function GetCurrentDirectory Lib "kernel32" Alias "GetCurrentDirectoryA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Declare PtrSafe Function getDiskFreespace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Private Declare PtrSafe Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As Long) As Long 'SECURITY_ATTRIBUTES >> Long
Private Declare PtrSafe Function CreateDirectoryEx Lib "kernel32" Alias "CreateDirectoryExA" (ByVal lpTemplateDirectory As String, ByVal lpNewDirectory As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Declare PtrSafe Function RemoveDirectory Lib "kernel32" Alias "RemoveDirectoryA" (ByVal lpPathName As String) As Long
Private Declare PtrSafe Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
Private Declare PtrSafe Function GetShortPathName Lib "kernel32.dll" Alias "GetShortPathNameA" _
  (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer _
  As Long) As Long
'''''''''''''

' GetTempFileName() Flags
'
Const TF_FORCEDRIVE = &H80

Private Declare PtrSafe Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare PtrSafe Function SetHandleCount Lib "kernel32" (ByVal wNumber As Long) As Long
Private Declare PtrSafe Function GetLogicalDrives Lib "kernel32" () As Long
Private Declare PtrSafe Function LockFile Lib "kernel32" (ByVal hfile As LongPtr, ByVal dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, ByVal nNumberOfBytesToLockLow As Long, ByVal nNumberOfBytesToLockHigh As Long) As Long
Private Declare PtrSafe Function UnlockFile Lib "kernel32" (ByVal hfile As LongPtr, ByVal dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, ByVal nNumberOfBytesToUnlockLow As Long, ByVal nNumberOfBytesToUnlockHigh As Long) As Long
Private Declare PtrSafe Function LockFileEx Lib "kernel32" (ByVal hfile As LongPtr, ByVal dwFlags As Long, ByVal dwReserved As Long, ByVal nNumberOfBytesToLockLow As Long, ByVal nNumberOfBytesToLockHigh As Long, lpOverlapped As OVERLAPPED) As Long

Const LOCKFILE_FAIL_IMMEDIATELY = &H1
Const LOCKFILE_EXCLUSIVE_LOCK = &H2

Private Declare PtrSafe Function UnlockFileEx Lib "kernel32" (ByVal hfile As LongPtr, ByVal dwReserved As Long, ByVal nNumberOfBytesToUnlockLow As Long, ByVal nNumberOfBytesToUnlockHigh As Long, lpOverlapped As OVERLAPPED) As Long

Private Type BY_HANDLE_FILE_INFORMATION
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        dwVolumeSerialNumber As Long
        nFileSizeHigh As Long
        nFileSizeLow As Long
        nNumberOfLinks As Long
        nFileIndexHigh As Long
        nFileIndexLow As Long
End Type

Private Declare PtrSafe Function GetFileInformationByHandle Lib "kernel32" (ByVal hfile As LongPtr, lpFileInformation As BY_HANDLE_FILE_INFORMATION) As Long
Private Declare PtrSafe Function GetFileType Lib "kernel32" (ByVal hfile As LongPtr) As Long
Private Declare PtrSafe Function GetFileSize Lib "kernel32" (ByVal hfile As LongPtr, lpFileSizeHigh As Long) As Long
Private Declare PtrSafe Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As LongPtr
Private Declare PtrSafe Function SetStdHandle Lib "kernel32" (ByVal nStdHandle As Long, ByVal nHandle As LongPtr) As Long
Private Declare PtrSafe Function WriteFile Lib "kernel32" (ByVal hfile As LongPtr, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare PtrSafe Function ReadFile Lib "kernel32" (ByVal hfile As LongPtr, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare PtrSafe Function FlushFileBuffers Lib "kernel32" (ByVal hfile As LongPtr) As Long
Private Declare PtrSafe Function DeviceIoControl Lib "kernel32" (ByVal hDevice As LongPtr, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare PtrSafe Function SetEndOfFile Lib "kernel32" (ByVal hfile As LongPtr) As Long
Private Declare PtrSafe Function SetFilePointer Lib "kernel32" (ByVal hfile As LongPtr, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As LongPtr) As Long
Private Declare PtrSafe Function GetFileTime Lib "kernel32" (ByVal hfile As LongPtr, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare PtrSafe Function SetFileTime Lib "kernel32" (ByVal hfile As LongPtr, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function DuplicateHandle Lib "kernel32" (ByVal hSourceProcessHandle As LongPtr, ByVal hSourceHandle As LongPtr, ByVal hTargetProcessHandle As LongPtr, lpTargetHandle As LongPtr, ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long

Private Declare PtrSafe Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private Declare PtrSafe Function GetDiskFreeSpaceEx Lib "kernel32" Alias _
"GetDiskFreeSpaceExA" (ByVal _
lpDirectoryName As String, _
lpFreeBytesAvailableToCaller As Double, _
lpTotalNumberOfBytes As Double, _
lpTotalNumberOfFreeBytes As Double) As Long

' SHLWAPI.DLL
Private Declare PtrSafe Function PathAddBackslash Lib "SHLWAPI.DLL" Alias "PathAddBackslashA" (ByVal pszPath As String) As LongPtr
Private Declare PtrSafe Function Api_PathAddBackslash Lib "shlwapi" Alias "PathAddBackslashA" (ByVal pszPath$)
Private Declare PtrSafe Function PathIsDirectory Lib "SHLWAPI.DLL" Alias "PathIsDirectoryA" (ByVal pszPath As String) As Boolean
' フォルダファイルの属性
Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName$) As Long
'パスからファイル名を取得
Private Declare PtrSafe Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Long) As Long
Private Declare PtrSafe Function CreateFile Lib "kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
lpSecurityAttributes As SECURITY_ATTRIBUTES, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As LongPtr

# Else
Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type
Private Type OVERLAPPED
        Internal As Long
        InternalHigh As Long
        offset As Long
        OffsetHigh As Long
        hEvent As Long
End Type

Private Declare Function PathFileExists Lib "SHLWAPI.DLL" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long


' GetTempFileName() Flags
'
Const TF_FORCEDRIVE = &H80

Private Declare FunctionGetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare FunctionSetHandleCount Lib "kernel32" Alias "SetHandleCount" (ByVal wNumber As Long) As Long
Private Declare FunctionGetLogicalDrives Lib "kernel32" Alias "GetLogicalDrives" () As Long
Private Declare FunctionLockFile Lib "kernel32" Alias "LockFile" (ByVal hFile As Long, ByVal dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, ByVal nNumberOfBytesToLockLow As Long, ByVal nNumberOfBytesToLockHigh As Long) As Long
Private Declare FunctionUnlockFile Lib "kernel32" Alias "UnlockFile" (ByVal hFile As Long, ByVal dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, ByVal nNumberOfBytesToUnlockLow As Long, ByVal nNumberOfBytesToUnlockHigh As Long) As Long
Private Declare FunctionLockFileEx Lib "kernel32" Alias "LockFileEx" (ByVal hFile As Long, ByVal dwFlags As Long, ByVal dwReserved As Long, ByVal nNumberOfBytesToLockLow As Long, ByVal nNumberOfBytesToLockHigh As Long, lpOverlapped As OVERLAPPED) As Long

Const LOCKFILE_FAIL_IMMEDIATELY = &H1
Const LOCKFILE_EXCLUSIVE_LOCK = &H2

Private Declare FunctionUnlockFileEx Lib "kernel32" Alias "UnlockFileEx" (ByVal hFile As Long, ByVal dwReserved As Long, ByVal nNumberOfBytesToUnlockLow As Long, ByVal nNumberOfBytesToUnlockHigh As Long, lpOverlapped As OVERLAPPED) As Long

Type BY_HANDLE_FILE_INFORMATION
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        dwVolumeSerialNumber As Long
        nFileSizeHigh As Long
        nFileSizeLow As Long
        nNumberOfLinks As Long
        nFileIndexHigh As Long
        nFileIndexLow As Long
End Type
Private Declare Function GetFileInformationByHandle Lib "kernel32" Alias "GetFileInformationByHandle" (ByVal hFile As Long, lpFileInformation As BY_HANDLE_FILE_INFORMATION) As Long
Private Declare Function GetFileType Lib "kernel32" Alias "GetFileType" (ByVal hFile As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" Alias "GetFileSize" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function GetStdHandle Lib "kernel32" Alias "GetStdHandle" (ByVal nStdHandle As Long) As Long
Private Declare Function SetStdHandle Lib "kernel32" Alias "SetStdHandle" (ByVal nStdHandle As Long, ByVal nHandle As Long) As Long
Private Declare Function WriteFile Lib "kernel32" Alias "WriteFile" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function ReadFile Lib "kernel32" Alias "ReadFile" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function FlushFileBuffers Lib "kernel32" Alias "FlushFileBuffers" (ByVal hFile As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" Alias "DeviceIoControl" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function SetEndOfFile Lib "kernel32" Alias "SetEndOfFile" (ByVal hFile As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" Alias "SetFilePointer" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function FindClose Lib "kernel32" Alias "FindClose" (ByVal hFindFile As Long) As Long
Private Declare Function GetFileTime Lib "kernel32" Alias "GetFileTime" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function SetFileTime Lib "kernel32" Alias "SetFileTime" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function CloseHandle Lib "kernel32" Alias "CloseHandle" (ByVal hObject As Long) As Long
Private Declare Function DuplicateHandle Lib "kernel32" Alias "DuplicateHandle" (ByVal hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal hTargetProcessHandle As Long, lpTargetHandle As Long, ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long

Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias _
"GetDiskFreeSpaceExA" (ByVal _
lpDirectoryName As String, _
lpFreeBytesAvailableToCaller As Double, _
lpTotalNumberOfBytes As Double, _
lpTotalNumberOfFreeBytes As Double) As Long

Private Declare Function PathAddBackslash Lib "SHLWAPI.DLL" Alias "PathAddBackslashA" (ByVal pszPath As String) As Long
'指定されたパスが空のディレクトリであるか
Private Declare PtrSafe Function PathIsDirectoryEmpty Lib "SHLWAPI.DLL" Alias "PathIsDirectoryEmptyA" (ByVal pszPath As String) As Boolean
' フォルダファイルの属性
Private Declare Function GetFileAttributes Lib "KERNEL32" Alias "GetFileAttributesA" (ByVal lpFileName$) As Long
Private  Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As long) As long
'CreateFile 20190605追加
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
lpSecurityAttributes As SECURITY_ATTRIBUTES, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
# End If

Private Function Win32APiPathFileExistsA(strfilename) As Boolean
Win32APiPathFileExistsA = CBool(Abs(PathFileExists(strfilename)) * (-1))
End Function
Property Get getPathFileExistsAValue(strfilename) As Boolean
getPathFileExistsAValue = Win32APiPathFileExistsA(strfilename)
End Property
Private Function fnPathAddBackslash(pszPath) As String
  'パスに\を追加（PathAddBackslash）
  #If VBA7 Then
  Dim Rc As LongPtr
  #Else
  Dim Rc As Long
  #End If
  Dim buf As String
  Dim strAddBackSlashPath As String * MAX_PATH
  strAddBackSlashPath = pszPath & String$(4096, vbNullChar)
  Rc = PathAddBackslash(ByVal strAddBackSlashPath)
  fnPathAddBackslash = Left$(strAddBackSlashPath, InStr(strAddBackSlashPath, vbNullChar) - 1)
End Function
'accessor アクセサ
Property Get strWindir() As String
    Dim strWinDirBuf As String * MAX_PATH
    Dim lngWinDirLen As Long
   lngWinDirLen = GetWindowsDirectory(strWinDirBuf, Len(strWinDirBuf))
   strWindir = Left$(strWinDirBuf, InStr(strWinDirBuf, vbNullChar) - 1)
End Property
Property Get strSysDir() As String
    Dim strWinDirBuf As String * MAX_PATH
    Dim lngWinDirLen As Long
   lngWinDirLen = GetSystemDirectory(strWinDirBuf, Len(strWinDirBuf))
   strSysDir = Left$(strWinDirBuf, InStr(strWinDirBuf, vbNullChar) - 1)
End Property
Property Get DirAddSlash(pszPath) As String
DirAddSlash = fnPathAddBackslash(pszPath)
End Property
Property Get strTempPath() As String
    Dim strBuffer As String                                         ' API用作業バッファ
    Dim lngLngs As Long                                             ' 〃文字列長
    ' Bufferを確保
    strBuffer = String(256, Chr(0))
    lngLngs = Len(strBuffer)
    ' TEMPフォルダ名取得(API呼び出し)   ※動作失敗は無視しています
    Call GetTempPath(lngLngs, strBuffer)
    ' Null文字の手前までを有効として表示
   strTempPath = Left$(strBuffer, InStr(1, strBuffer, Chr(0)) - 1)

End Property
Property Get blEmptyDirectory(strDirectory) As Boolean
blEmptyDirectory = CBool(PathIsDirectoryEmpty(strDirectory))
End Property
Property Get blPathIsDirectory(strDirecory) As Boolean
blPathIsDirectory = PathIsDirectory(strDirecory)
End Property
Private Function DriveTypeList() As String
'[Windowsディレクトリを取得する ]
    Dim drives As Long          'ディスクドライブのビットマスク
    Dim i As Integer            'カウンタ
    Dim DriveType As Long      'ドライブタイプ
    Dim strDriveLetter As String
    Dim strResult As String
   '現在利用可能なディスクドライブをビットマスク形式で取得
    '現在利用可能なディスクドライブをビットマスク形式で取得
    drives = GetLogicalDrives()

    '関数の失敗
    If drives = 0& Then Exit Function

    'A～Zドライブを検索する
    For i = 0 To 25
        '最初0ビット目(A)を確かめる、1と論理結合させることで
        '0か1かがわかる。真(1)の時のみドライブ名として列挙する
        If (drives And 1&) = 1& Then
           strDriveLetter = Chr(65 + i)  'ドライブ名(A～Z)に変換
            strDriveLetter = strDriveLetter & ":\"
'～追加部分～

            'そのドライブがどういうドライブタイプかをチェックする
            DriveType = GetDriveType(strDriveLetter)
            Select Case DriveType
                Case DRIVE_REMOVABLE
                     strResult = strResult & (strDriveLetter & "   リムーバブルディスク") & vbCrLf
                Case DRIVE_FIXED
                    strResult = strResult & (strDriveLetter & "   ハードディスク") & vbCrLf
                Case DRIVE_REMOTE
                    strResult = strResult & (strDriveLetter & "   ネットワーク") & vbCrLf
                Case DRIVE_CDROM
                    strResult = strResult & (strDriveLetter & "   CD-ROMドライブ") & vbCrLf
                Case DRIVE_RAMDISK
                    strResult = strResult & (strDriveLetter & "   RAMドライブ") & vbCrLf
                Case Else
                    strResult = strResult & (strDriveLetter & "   不明ドライブ") & vbCrLf
            End Select
'～追加部分～

        End If
        '1ビットずつシフトさせていき、検索を続ける
        drives = drives \ 2&
    Next i
 DriveTypeList = strResult
End Function
Property Get getLogicalDriveList() As String
getLogicalDriveList = DriveTypeList
End Property
Property Get LogicalDriveType(DriveletterIs As String) As String
Dim DriveType As Long

            DriveType = GetDriveType(DriveletterIs)
            Select Case DriveType
                Case DRIVE_REMOVABLE
                  LogicalDriveType = DriveletterIs & "   リムーバブルディスク"
                Case DRIVE_FIXED
                    LogicalDriveType = DriveletterIs & "   ハードディスク"
                Case DRIVE_REMOTE
                    LogicalDriveType = DriveletterIs & "   ネットワーク"
                Case DRIVE_CDROM
                    LogicalDriveType = DriveletterIs & "   CD-ROMドライブ"
                Case DRIVE_RAMDISK
                    LogicalDriveType = DriveletterIs & "   RAMドライブ"
                Case Else
                    LogicalDriveType = DriveletterIs & "   不明ドライブ"
            End Select
End Property


' ドライブの空き容量を得る。
Private Function DiskFreeSpace(ByVal MODE As String, _
                        strDriveRoot As String) As Currency
    ' strDriveRoot : ドライブのルート(例: "C:\")
    Dim lngResult                As Long
    Dim curFreeAvailableToCaller As Long
    Dim curTotalByte             As Long
    Dim curTotalFreeByte         As Long
    Dim lpTotalNumberOfClusters As Long
    lngResult = getDiskFreespace(strDriveRoot, _
                                   curFreeAvailableToCaller, _
                                   curTotalByte, _
                                   curTotalFreeByte, lpTotalNumberOfClusters)
    Select Case MODE
        Case "空き容量"
            ' 通貨型で受けて、10000倍するとVBで正しい数値となる。
            DiskFreeSpace = curTotalFreeByte * 10000@
        Case "ディスク容量"
            ' 全容量なら curTotalByte * 10000@ で得られる。
            DiskFreeSpace = curTotalByte * 10000@
    End Select
    
End Function
Property Get lgDiskFreespace(strMode As String, strDriveRootis As String) As Currency
lgDiskFreespace = DiskFreeSpace("空き容量", strDriveRootis)

End Property
Property Get dblDiskFreeSpaceEx(strDriveRootis As String) As Double
Dim Re As Long
Dim lpFreeBytesAvailableToCaller As Double
Dim iTotalBytes As Double
Dim iFreeBytes As Double
Dim TotalBytes As Double
Dim FreeBytes As Double
'Ｃドライブの容量を得るとすると、
Re = GetDiskFreeSpaceEx(fnPathAddBackslash(strDriveRootis), lpFreeBytesAvailableToCaller, iTotalBytes, iFreeBytes)
dblDiskFreeSpaceEx = iFreeBytes / 4.94065645841247E-324
End Property
Property Get dblDiskTotalSpaceEx(strDriveRootis As String) As Double
Dim Re As Long
Dim lpFreeBytesAvailableToCaller As Double
Dim iTotalBytes As Double
Dim iFreeBytes As Double
Dim TotalBytes As Double
Dim FreeBytes As Double
'Ｃドライブの容量を得るとすると、
Re = GetDiskFreeSpaceEx(fnPathAddBackslash(strDriveRootis), lpFreeBytesAvailableToCaller, iTotalBytes, iFreeBytes)
'全容量
dblDiskTotalSpaceEx = iTotalBytes / 4.94065645841247E-324
End Property


' ディレクトリの作成
'Property Get DoCreateDir(strNewpath) As Boolean
'  Dim bResult As Long
'
'  bResult = CreateDirectory(strNewpath, 0)
'  If bResult = 0 Then
'    Debug.Print "エラー発生"
'    If Err.LastDllError = ERROR_ALREADY_EXISTS Then
'      Debug.Print "既にディレクトリが存在している"
'    End If
'    DoCreateDir = CBool(bResult)
'
'  Else
'    DoCreateDir = CBool(bResult)
'  End If
'End Property
Property Get strCurrentDirectory() As String
'https://www.mrexcel.com/forum/excel-questions/828344-getcurrentdirectory-api-function.html
Dim Dir As String * 255
Dim Length As String * 255
Length = GetCurrentDirectory(Len(Length), Dir)
strCurrentDirectory = Dir
End Property
Public Sub Api_SetCuurentDirectory(strPath As String)
'http://www.majishini.net/wp/?p=412

' Rc = Api_SetCuurentDirectory = SetCurrentDirectory(StrPtr(strPath))
' Api_SetCuurentDirectory = Rc
'http://officetanaka.net/other/extra/tips15.htm
SetCurrentDirectory strPath
End Sub
'ファイルフォルダの属性
Property Get PathFileAttribute(strPathFileName As String) As String
    'http://madia.world.coocan.jp/
    Dim Ret As Long

     Ret = GetFileAttributes(strPathFileName)

Select Case Ret

  Case FILE_ATTRIBUTE_ARCHIVE
         PathFileAttribute = "アーカイブ属性"
  Case FILE_ATTRIBUTE_DIRECTORY
        PathFileAttribute = "ディレクトリ属性"
  Case FILE_ATTRIBUTE_HIDDEN
         PathFileAttribute = "隠しファイル属性"
  Case FILE_ATTRIBUTE_NORMAL
         PathFileAttribute = "ファイル属性は持っていません"
  Case FILE_ATTRIBUTE_READONLY
        MsgBox "読み込み専用属性"
  Case FILE_ATTRIBUTE_SYSTEM
         PathFileAttribute = "システムファイル属性"

End Select
End Property
Property Get strFileTitle(strFullname As String) As String
' http://madia.world.coocan.jp/
    Dim nName As String
    Dim nLeng As Long
    Dim Ret As Long

    'バッファを確保
    nName = String(250, Chr(0))
    nLeng = Len(nName)

    Ret = GetFileTitle(strFullname, nName, nLeng)
    strFileTitle = nName

End Property
Property Get strFullpath(strPath As String) As String
Dim buffer As String  ' receives path and filename string
Dim numchar As Long  ' receives length of buffer after function call
buffer = Space(255)  ' make room for buffer to receive the string
Call Api_SetCuurentDirectory(Replace(strFullpath, Me.strFileTitle(strPath), "", 1, 1, vbTextCompare))
numchar = GetFullPathName(Me.strFileTitle(strPath), 255, buffer, "")  ' put the result string into1 buffer
buffer = Left(buffer, numchar)  ' extract data from the returned string
strFullpath = buffer ' Return
End Property
Property Get strShortPath(strPath As String) As String
  Dim shortname As String  ' receives short-filename equivalent
  Dim slength As Long  ' receives length of short-filename equivalent
  
  ' Make room in the buffer to receive the 8.3 form of the filename.
  shortname = Space(256)
  ' Get the 8.3 form of the filename specified.
  slength = GetShortPathName(strPath, shortname, 256)
  ' Remove the trailing null and display the result.
  shortname = Left(shortname, slength)
  Debug.Print "Equivalent: "; shortname
  strShortPath = shortname
End Property
Property Get lgFileSize(strPath As String)
'Win32 Api は Fileを開くため複雑になり、うまくいかないので、Filesystemobjectです
'File Folder いずれでもサイズを返し、エラーは-1を返します。
On Error Resume Next
With CreateObject("Scripting.Filesystemobject")
If Err.Number = 0 And fso.FolderExists(strPath) = True Then
lgFileSize = .GetFolder(strPath).Size
ElseIf Err.Number = 0 And .FileExists(strPath) = True Then
lgFileSize = .GetFile(strPath).Size
Else
lgFileSize = -1
End If
End With
End Property

Property Get lgFIleSizeAPI(strPath As String) As Long
'20190605追加
'Fileのサイズを返します
'Folderだと0を返します。

Dim tSecurityAttributes As SECURITY_ATTRIBUTES
Dim lngFileSizeHigh As Long
'https://tsware.jp/labo/labo_25.htm
tSecurityAttributes.nLength = Len(tSecurityAttributes) 'SECURITY_ATTRIBUTES Initialize
lngOpenFHwnd = CreateFile(strPath, _
GENERIC_READ, 0, _
tSecurityAttributes, _
OPEN_EXISTING, 0, 0)
If lngOpenFHwnd <> -1 Then
lgFIleSizeAPI = GetFileSize(lngOpenFHwnd, lngFileSizeHigh)
Debug.Print lngFileSize
'ファイルをクローズ
lngret = CloseHandle(lngOpenFHwnd)
End If
End Property