VBCommons/api/API_Path.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "API_Path"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ================ Ðàáîòà ñ ïóòÿìè ê ôàéëàì =============
' Shared module version: 20221031
' Tested in: TestCommons
' Depends on: ex_VBA
' Required reference: Scripting
Option Explicit

Private Enum PathType
  T_PATH_INVALID = 0

  T_PATH_GLOBAL = 1
  T_PATH_LOCAL = 2
  T_PATH_ENVIRON = 3
End Enum

Private data_ As String
Private type_ As PathType

Public Function FromString(sText$) As API_Path
  data_ = sText
  type_ = InternalEvaluate(data_)
  Set FromString = Me
End Function

Public Function Clone() As API_Path
  Set Clone = New API_Path
  Call Clone.FromString(data_)
End Function

Public Property Get Text() As String
  Text = data_
End Property

Public Property Get ParentFolder() As String
  Dim fso As New Scripting.FileSystemObject
  ParentFolder = fso.GetParentFolderName(data_)
End Property

Public Property Get FileName() As String
  Dim fso As New Scripting.FileSystemObject
  FileName = fso.GetFileName(data_)
End Property

Public Property Get BaseName() As String
  Dim fso As New Scripting.FileSystemObject
  BaseName = fso.GetBaseName(data_)
End Property

Public Property Get Extension() As String
  Dim fso As New Scripting.FileSystemObject
  Extension = fso.GetExtensionName(data_)
End Property

Public Function ToGlobal(sHome$) As API_Path
  Select Case type_
    Case T_PATH_LOCAL: data_ = ConvertLocal(data_, sHome)
    Case T_PATH_ENVIRON: data_ = ConvertEnviron(data_)
    Case T_PATH_INVALID, T_PATH_GLOBAL:
  End Select
  type_ = InternalEvaluate(data_)
  Set ToGlobal = Me
End Function

Public Function ToLocal(sHome$) As API_Path
  Set ToLocal = Me
  Dim nPrefix&: nPrefix = CommonPrefixLength(data_, sHome, vbTextCompare)
  If nPrefix = 0 Then _
    Exit Function
  
  If VBA.Mid(data_, nPrefix, 1) = "\" Then
    nPrefix = nPrefix - 1
  ElseIf VBA.Mid(data_, nPrefix + 1, 1) <> "\" Then
    nPrefix = VBA.InStrRev(data_, "\", nPrefix)
    If nPrefix < 3 Then _
      Exit Function
  End If
  
  Dim fso As New Scripting.FileSystemObject
  Dim sFolder$: sFolder = sHome
  Dim sPrefix$
  Do While VBA.Len(sFolder) > nPrefix
    sFolder = fso.GetParentFolderName(sFolder)
    sPrefix = sPrefix & "..\"
  Loop
  
  data_ = VBA.Right(data_, VBA.Len(data_) - nPrefix - 1)
  If sPrefix <> vbNullString Then _
    data_ = sPrefix & data_
  type_ = InternalEvaluate(data_)
End Function

Public Function ToServer(sHome$) As API_Path
  Call ToGlobal(sHome)
  data_ = SubstituteServer(data_)
  type_ = InternalEvaluate(data_)
  Set ToServer = Me
End Function

Public Function GlobalToServer() As API_Path
  data_ = SubstituteServer(data_)
  type_ = InternalEvaluate(data_)
  Set GlobalToServer = Me
End Function

Public Function LocalExists(sHome$) As Boolean
  Dim sFile$
  If type_ = T_PATH_LOCAL Then
    sFile = ConvertLocal(data_, sHome)
  Else
    sFile = data_
  End If
  LocalExists = CheckPath(sFile)
End Function

Public Function GlobalExists() As Boolean
  GlobalExists = CheckPath(data_)
End Function

' ========
Private Function InternalEvaluate(sPath$) As PathType
  If VBA.Len(sPath) < 3 Then
    InternalEvaluate = T_PATH_INVALID
  ElseIf VBA.Mid(sPath, 2, 1) = ":" Or VBA.Left(sPath, 2) = "\\" Then
    InternalEvaluate = T_PATH_GLOBAL
  ElseIf sPath Like "%*%*" Then
    InternalEvaluate = T_PATH_ENVIRON
  Else
    InternalEvaluate = T_PATH_LOCAL
  End If
End Function

Private Function SubstituteServer(sPath$) As String
  If VBA.Len(sPath) < 3 Then
    SubstituteServer = sPath
  ElseIf VBA.Left(sPath, 3) = "P:\" Then
    SubstituteServer = "\\fs1.concept.ru\projects\" & VBA.Right(sPath, VBA.Len(sPath) - 3)
  ElseIf VBA.Left(sPath, 3) = "X:\" Then
    SubstituteServer = "\\fs1.concept.ru\Exchange\" & VBA.Right(sPath, VBA.Len(sPath) - 3)
  Else
    SubstituteServer = sPath
  End If
End Function

Private Function ConvertLocal(sPath$, sHome$) As String
  Dim nEllipsis&: nEllipsis = VBA.InStrRev(sPath, "..\")
  If nEllipsis = 0 Then
    ConvertLocal = sHome & "\" & sPath
  Else
    Dim fso As New Scripting.FileSystemObject
    Dim nCount&: nCount = 1 + nEllipsis / 3
    Dim sFolder$: sFolder = sHome
    Do While nCount > 0
      sFolder = fso.GetParentFolderName(sFolder)
      nCount = nCount - 1
    Loop
    ConvertLocal = sFolder & "\" & VBA.Right(sPath, VBA.Len(sPath) - nEllipsis - 2)
  End If
End Function

Private Function ConvertEnviron(sPath$) As String
  Dim nHeader&: nHeader = VBA.InStr(2, sPath, "%")
  Dim sVariable$: sVariable = VBA.Mid(sPath, 2, nHeader - 2)
  ConvertEnviron = VBA.Environ$(sVariable) & "\" & VBA.Right(sPath, VBA.Len(sPath) - nHeader - 1)
End Function

Private Function CheckPath(sPath$) As Boolean
  Dim fso As New Scripting.FileSystemObject
  CheckPath = True
  If fso.FileExists(sPath) Then _
    Exit Function
  If fso.FolderExists(sPath) Then _
    Exit Function
  CheckPath = False
End Function