Attribute VB_Name = "FileSystem"
'Patrick O'Beirne, Systems Modelling Ltd
'pob at sysmod.com
'http://www.sysmod.com
'http://ie.linkedin.com/in/patrickobeirne
'http://sysmod.wordpress.com
't: @ExcelAnalytics
'VBA code for using the Filesystem object to replace the old VB functions
'  like Dir() that do not work with Unicode file names
'https://sysmod.wordpress.com/2021/01/11/hello-the-rest-of-the-world-reading-data-in-other-languages/

Option Explicit
Option Private Module
Private Const SUCCESS As Long = 0
Private Const MAX_PATH As Long = 260
Private Const T_ALL_XL  As String = "All Excel files (*.xl*), *.xl*"

'---------------------------------------------------------------------------------------------------
'Windows API declarations for VBA7
Private Declare PtrSafe Function GetCurrentDirectoryW Lib "kernel32" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare PtrSafe Function SetCurrentDirectoryW Lib "kernel32" (ByVal lpBuffer As String) As Long

'Open file for Binary raises err 52 for Unicode file or folder names
'Dir(), Filelen(), FileDateTime() cannot handle them either
'The File System Object can read only ASCII or Unicode text files.
'You cannot use it to read or write UTF-8 encoded text files.
' These functions are usable with Unicode file names

Function GetCurDir() As String ' WinAPI to replace CurDir for Unicode folder names
   Dim lBuffer As Long, sBuffer As String
   sBuffer = String(MAX_PATH * 2, 0)
   lBuffer = GetCurrentDirectoryW(MAX_PATH * 2, sBuffer)
   sBuffer = StrConv(sBuffer, vbFromUnicode)
   GetCurDir = Left$(sBuffer, lBuffer)
End Function

Function ChPath(sPath As String) As Long
   On Error Resume Next
   If Mid$(sPath, 2, 1) = ":" Then
      ChDrive Left$(sPath, 2)
   End If
   SetCurDir sPath ' to replace ChDir sPath. Changes both drive and path if necessary, no ChDrive needed
   ChPath = Err.Number
End Function

Function SetCurDir(path As String) As Long ' replace ChDir for Unicode, ChDirW. Use ChPath to be safe
   SetCurDir = SetCurrentDirectoryW(StrConv(path, vbUnicode)) ' WinAPI returns 1 if works, 0 if error
End Function

'---------------------------------------------------------------------------------------------------
' FileSystemObject functions

Function NewFSO() As Object
   Set NewFSO = CreateObject("Scripting.FileSystemObject")
End Function
'https://support.microsoft.com/en-us/topic/how-to-use-filesystemobject-with-visual-basic-9f39e1fa-bbf2-b252-0b5c-33048b07dc8e
'FileSystemObject provides a non-hierarchical structure to manipulate, read, and create ASCII and Unicode text files.
' neither of these two next compile, get Method or data member not found
' Set NewFSO = Scripting.FileSystemObject
' Set NewFSO = IWshRuntimeLibrary.FileSystemObject 'Windows Script Host Object Model C:\Windows\SysWOW64\wshom.ocx

' use this instead of DIR$() which cannot handle Unicode file names, throws err 52 Bad file name or number
Function GetFSOFile(FilePath As String, oFSOFile As Object) As Long
   ' only for local X:\dir\file.xls or \\net\dir\file.xls, not http: etc
   ' fso.getfile throws err 53 file not found if it's not local
   On Error Resume Next
   Set oFSOFile = Nothing
   Set oFSOFile = NewFSO().GetFile(FilePath)
   GetFSOFile = Err.Number
End Function

Function FileExists(ByVal Pathname As String) As Boolean ' to replace DIR(name)>"" for files only, not wildcards, not folders
   Dim oFSOFile As Object
   FileExists = GetFSOFile(Pathname, oFSOFile) = SUCCESS
End Function

Function FolderExists(ByVal Pathname As String) As Boolean ' for folders, to replace DIR(name,vbDirectory)
   Dim oFSOFile As Object
   FolderExists = GetFSOFolder(Pathname, oFSOFile) = SUCCESS
End Function

' these simple functions wrap the FSOFile properties for compatibility
' but it might be cleaner to switch old code calling (eg) FileLen to use FSOFile.Size

Function GetPathAndName(ByVal FullName As String, ByRef path As String, ByRef name As String) As Long
   ' get the path and name parts
   Dim oFSOFile As Object ' ADODB.File
   GetPathAndName = GetFSOFile(FullName, oFSOFile)
   If GetPathAndName = SUCCESS Then
      path = oFSOFile.parentfolder.path
      name = oFSOFile.name
   End If
End Function

Public Function FileSize(ByVal filename As String) As Double ' to replace FileLen()
   Dim oFSOFile As Object
   If GetFSOFile(filename, oFSOFile) = SUCCESS Then
      FileSize = oFSOFile.Size
   End If
End Function

Public Function FileDateModified(ByVal filename As String) As Double ' to replace FileDateTime()
   Dim oFSOFile As Object
   If GetFSOFile(filename, oFSOFile) = SUCCESS Then
      FileDateModified = oFSOFile.datemodified
   End If
End Function

Function CopyFile(ByVal filename As String, ByVal CopyName As String) As Long ' to replace VBA.FileCopy "x","y"
   On Error Resume Next
   NewFSO().CopyFile filename, CopyName
   CopyFile = Err.Number
End Function

Function RenameFile(ByVal oldName As String, ByVal newName As String) As Long ' to replace VBA.Name "x" As "y"
   On Error Resume Next
   NewFSO().movefile oldName, newName
   RenameFile = Err.Number
End Function

Function DeleteFile(ByVal Pathname As String) As Long ' aka KillFile to replace VBA.Kill
   If FileExists(Pathname) Then
      SetFileAttributes Pathname, vbNormal
   End If
   On Error Resume Next
   NewFSO().DeleteFile Pathname
   DeleteFile = Err.Number ' eg 70=Permission denied
End Function

' Windows API has GetTempFileName
Function GetTempName(ByRef TempName As String) As Long
   On Error Resume Next
   TempName = NewFSO().GetTempName ' does NOT create the file. returns a name like radBE37A.tmp
   GetTempName = Err.Number
End Function

Function GetTempFullName(ByRef tempFullName As String) As Long
   On Error Resume Next
   With NewFSO()
      tempFullName = .GetSpecialFolder(2) & Application.PathSeparator & .GetTempName
   End With
   ' does NOT create the file. returns a name like C:\Users\Patrick\AppData\Local\Temp\rad9C3F3.tmp
   GetTempFullName = Err.Number
End Function

Function GetFSOFolder(FolderPath As String, oFSOFolder As Object) As Long ' returns 0=success
   ' only for local X:\dir\file.xls or \\net\dir\file.xls, not http: etc
   ' fso.getfile throws err 53 file not found if it's not local
   On Error Resume Next
   Set oFSOFolder = Nothing
   Set oFSOFolder = NewFSO().GetFolder(FolderPath)
   GetFSOFolder = Err.Number
End Function

Function CreateFolder(ByVal Pathname As String) As Long  ' to replace MkDir
   On Error Resume Next
   NewFSO().CreateFolder Pathname
   CreateFolder = Err.Number
End Function

Function DeleteFolder(ByVal Pathname As String) As Long ' to replace RmDir
   On Error Resume Next
   NewFSO().DeleteFolder Pathname
   DeleteFolder = Err.Number
End Function

Function GetFileAttributes(sFile As String) As Long ' replace GetAttr for Unicode
   'GetFileAttributes = GetFileAttributesW(StrPtr(sFile))
   Dim oFSOFile As Object
   If GetFSOFile(sFile, oFSOFile) = SUCCESS Then
      GetFileAttributes = oFSOFile.Attributes
   End If
End Function

Function SetFileAttributes(sFile As String, lAttrib As Long) As Long ' replace SetAttr for Unicode
   'SetFileAttributes = SetFileAttributesW(StrPtr(sFile), CLngPtr(lAttrib))
   Dim oFSOFile As Object
   SetFileAttributes = GetFSOFile(sFile, oFSOFile)
   If SetFileAttributes = SUCCESS Then ' 0=success
      oFSOFile.Attributes = lAttrib
   End If
End Function


' A file can be either compressed or encrypted, not both.
' indexing service which runs at SYSTEM level locks un-indexed files for 1-5 minutes and gives err=5 access denied
'http://support.microsoft.com/kb/329065
'http://lists.samba.org/archive/samba-technical/2005-January/038793.html
'http://msdn2.microsoft.com/en-us/library/aa365535.aspx
'Constant Value Description
'Normal 0 Normal file. No attributes are set.
'ReadOnly 1 Read-only file. Attribute is read/write.
'Hidden 2 Hidden file. Attribute is read/write.
'System 4 System file. Attribute is read/write.
'Volume 8 Disk drive volume label. Attribute is read-only.
'Directory 16 Folder or directory. Attribute is read-only.
'Archive 32 File has changed since last backup. Attribute is read/write.
'Alias 64 Link or shortcut. Attribute is read-only. (Device?)
'Compressed 128 Compressed file. Attribute is read-only. (Now Normal?)
Function FileAttrString(fa As Long, Optional strPad As String = vbNullString) As String
   FileAttrString = _
      IIf(fa And 1, "R", strPad) _
      & IIf(fa And 2, "H", strPad) _
      & IIf(fa And 4, "S", strPad) _
      & IIf(fa And 8, "V", strPad) _
      & IIf(fa And 16, "D", strPad) _
      & IIf(fa And 32, "A", strPad) _
      & IIf(fa And 64, "L", strPad) _
      & IIf(fa And 128, " ", vbNullString) _
      & IIf(fa And 256, "t", vbNullString) _
      & IIf(fa And 512, "s", vbNullString) _
      & IIf(fa And 1024, "r", vbNullString) _
      & IIf(fa And 2048, "c", vbNullString) _
      & IIf(fa And 4096, "o", vbNullString) _
      & IIf(fa And 8192, "n", vbNullString) _
      & IIf(fa And 16384, "e", vbNullString) _
      & IIf(fa And 32768, "d", vbNullString)
End Function


Function GetOpenFilenameStr(Optional FileFilter As String = T_ALL_XL, Optional FilterIndex As Long = 1, _
   Optional Title As String = "Select", Optional ButtonText As String = "Open", _
   Optional MultiSelect As Boolean = False) As String
   'ButtonText  Optional    Variant  Macintosh only, Windows always "Open"
   Dim vFileName As Variant
   vFileName = Application.GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)
   If Not vFileName = False Then
      GetOpenFilenameStr = vFileName
   End If
End Function