Получение абсолютного пути к изображению

GetUNCPath – это метод преобразования любого пути в путь универсального соглашения об именах на сетевых дисках. Он вернет локальный диск как абсолютный путь, если он не подключен к сети. Я использую эту функцию, чтобы гарантировать, что у меня есть полный абсолютный путь.

Я написал приведенный ниже код (с некоторой помощью @GSerg), чтобы упростить преобразование пути в полный абсолютный UNC. дорожка.

Использование

Dim fullPath as string
fullPath = GetUNCPath("T:\SomeDir\SomeFile.Txt")

Он преобразует T:\SomeDir\SomeFile.Txt в \\SomeServer\SomeShare\SomeDir\SomeFile.Txt.

Это было протестировано на Access 2003 и Access 2010. Он совместим с 32-разрядными и 64-разрядными версиями.

Модуль: GetUNC

Option Compare Database
Option Explicit

#If VBA7 Then
  Private Declare PtrSafe Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionW" (ByVal lpLocalName As LongPtr, ByVal lpRemoteName As Long, lpnLength As Long) As Long
  Private Declare PtrSafe Function PathIsUNC Lib "shlwapi.dll" Alias "PathIsUNCW" (ByVal pszPath As LongPtr) As Long
  Private Declare PtrSafe Function PathIsNetworkPath Lib "shlwapi.dll" Alias "PathIsNetworkPathW" (ByVal pszPath As LongPtr) As Long
  Private Declare PtrSafe Function PathStripToRoot Lib "shlwapi.dll" Alias "PathStripToRootW" (ByVal pPath As LongPtr) As LongPtr
  Private Declare PtrSafe Function PathSkipRoot Lib "shlwapi.dll" Alias "PathSkipRootW" (ByVal pPath As LongPtr) As Long
  Private Declare PtrSafe Function PathRemoveBackslash Lib "shlwapi.dll" Alias "PathRemoveBackslashW" (ByVal strPath As LongPtr) As LongPtr
#Else
  Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionW" (ByVal lpLocalName As Long, ByVal lpRemoteName As Long, lpnLength As Long) As Long
  Private Declare Function PathIsUNC Lib "shlwapi.dll" Alias "PathIsUNCW" (ByVal pszPath As Long) As Long
  Private Declare Function PathIsNetworkPath Lib "shlwapi.dll" Alias "PathIsNetworkPathW" (ByVal pszPath As Long) As Long
  Private Declare Function PathStripToRoot Lib "shlwapi.dll" Alias "PathStripToRootW" (ByVal pPath As Long) As Long
  Private Declare Function PathSkipRoot Lib "shlwapi.dll" Alias "PathSkipRootW" (ByVal pPath As Long) As Long
  Private Declare Function PathRemoveBackslash Lib "shlwapi.dll" Alias "PathRemoveBackslashW" (ByVal strPath As Long) As Long
#End If

Public Function GetUNCPath(sLocalPath As String) As String
  Dim lResult As Long
#If VBA7 Then
  Dim lpResult As LongPtr
#Else
  Dim lpResult As Long
#End If
  Dim ASLocal As APIString
  Dim ASPath As APIString
  Dim ASRoot As APIString
  Dim ASRemoteRoot As APIString
  Dim ASTemp As APIString

  Set ASLocal = New APIString
  ASLocal.Value = sLocalPath

  If ASLocal.Pointer > 0 Then
    lResult = PathIsUNC(ASLocal.Pointer)
  End If
  If lResult <> 0 Then
    GetUNCPath = ASLocal.Value
    Exit Function
  End If

  If ASLocal.Pointer > 0 Then
    lResult = PathIsNetworkPath(ASLocal.Pointer)
  End If
  If lResult = 0 Then
    GetUNCPath = ASLocal.Value
    Exit Function
  End If

  ' Extract Root
  Set ASRoot = New APIString
  ASRoot.Value = sLocalPath
  If ASRoot.Length = 2 And Mid(ASRoot.Value, 2, 1) = ":" Then
    ' We have a Root with no Path
    Set ASPath = New APIString
    ASPath.Value = ""
  Else
    If ASRoot.Pointer > 0 Then
      lpResult = PathStripToRoot(ASRoot.Pointer)
    End If
    ASRoot.TruncToNull
    If ASRoot.Pointer > 0 And Mid(ASRoot.Value, ASRoot.Length) = "\" Then
      lpResult = PathRemoveBackslash(ASRoot.Pointer)
      ASRoot.TruncToPointer lpResult
    End If

    ' Extract Path
    Set ASPath = New APIString
    ASPath.Value = sLocalPath
    lpResult = PathSkipRoot(ASPath.Pointer)
    ASPath.TruncFromPointer lpResult
    If ASPath.Length > 0 Then
      If ASPath.Pointer > 0 And Mid(ASPath.Value, ASPath.Length) = "\" Then
        lpResult = PathRemoveBackslash(ASPath.Pointer)
        ASPath.TruncToPointer lpResult
      End If
    End If
  End If

  ' Resolve Local Root into Remote Root
  Set ASRemoteRoot = New APIString
  ASRemoteRoot.Init 255
  If ASRoot.Pointer > 0 And ASRemoteRoot.Pointer > 0 Then
    lResult = WNetGetConnection(ASRoot.Pointer, ASRemoteRoot.Pointer, LenB(ASRemoteRoot.Value))
  End If
  ASRemoteRoot.TruncToNull

  GetUNCPath = ASRemoteRoot.Value & ASPath.Value
End Function

Модуль класса: APIString

Option Compare Database
Option Explicit

 Private sBuffer As String

 Private Sub Class_Initialize()
   sBuffer = vbNullChar
 End Sub

 Private Sub Class_Terminate()
   sBuffer = ""
 End Sub

 Public Property Get Value() As String
   Value = sBuffer
 End Property

 Public Property Let Value(ByVal sNewStr As String)
   sBuffer = sNewStr
 End Property

 ' Truncates Length
#If VBA7 Then
  Public Sub TruncToPointer(ByVal lpNewUBound As LongPtr)
#Else
  Public Sub TruncToPointer(ByVal lpNewUBound As Long)
#End If
   Dim lpDiff As Long
   If lpNewUBound <= StrPtr(sBuffer) Then Exit Sub
   lpDiff = (lpNewUBound - StrPtr(sBuffer)) \ 2
   sBuffer = Mid(sBuffer, 1, lpDiff)
 End Sub

 ' Shifts Starting Point forward
#If VBA7 Then
 Public Sub TruncFromPointer(ByVal lpNewLBound As LongPtr)
#Else
 Public Sub TruncFromPointer(ByVal lpNewLBound As Long)
#End If
   Dim lDiff As Long
   If lpNewLBound <= StrPtr(sBuffer) Then Exit Sub
   If lpNewLBound >= (StrPtr(sBuffer) + LenB(sBuffer)) Then
     sBuffer = ""
     Exit Sub
   End If
   lDiff = (lpNewLBound - StrPtr(sBuffer)) \ 2
   sBuffer = Mid(sBuffer, lDiff)
 End Sub

 Public Sub Init(Size As Long)
   sBuffer = String(Size, vbNullChar)
 End Sub

Public Sub TruncToNull()
  Dim lPos As Long
  lPos = InStr(sBuffer, vbNullChar)
  If lPos = 0 Then Exit Sub
  sBuffer = Mid(sBuffer, 1, lPos - 1)
End Sub

Public Property Get Length() As Long
  Length = Len(sBuffer)
End Property

#If VBA7 Then
 Public Property Get Pointer() As LongPtr
#Else
 Public Property Get Pointer() As Long
#End If
   Pointer = StrPtr(sBuffer)
 End Property