如何用VBA提取Excel文件的原始服务器路径（本地临时文件场景）

问题背景 #

从SMB共享服务器打开Excel文件时，ActiveWorkbook.FullName仅返回本地临时缓存路径（如/Users/oliver/Library/Containers/com.microsoft.Excel/Data/Documents/FileName.xlsx），但ActiveWorkbook.Save可正常保存回原服务器路径，说明Excel已存储原始SMB路径信息，需通过VBA动态提取。

解决方案 #

针对Windows系统 #

使用Windows API函数GetFinalPathNameByHandleW获取文件的最终网络路径，以下是完整VBA代码：

Option Explicit

Private Declare PtrSafe Function CreateFileW Lib "kernel32" ( _
    ByVal lpFileName As LongPtr, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    lpSecurityAttributes As Any, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As LongPtr _
) As LongPtr

Private Declare PtrSafe Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As LongPtr _
) As Boolean

Private Declare PtrSafe Function GetFinalPathNameByHandleW Lib "kernel32" ( _
    ByVal hFile As LongPtr, _
    ByVal lpFilePath As LongPtr, _
    ByVal nBufferLength As Long, _
    ByVal dwFlags As Long _
) As Long

Private Const GENERIC_READ As Long = &H80000000
Private Const FILE_SHARE_READ As Long = &H1
Private Const OPEN_EXISTING As Long = 3
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const VOLUME_NAME_DOS As Long = &H0
Private Const FILE_NAME_OPENED As Long = &H8

Function GetTrueNetworkPath(LocalPath As String) As String
    Dim hFile As LongPtr
    Dim Buffer As String
    Dim BufferLen As Long
    Dim ResultLen As Long
    Dim FinalPath As String
    
    ' 打开文件获取句柄
    hFile = CreateFileW(StrPtr(LocalPath), GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
    
    If hFile <> -1 Then
        ' 初始化缓冲区
        BufferLen = 2048
        Buffer = String(BufferLen, vbNullChar)
        
        ' 获取最终路径
        ResultLen = GetFinalPathNameByHandleW(hFile, StrPtr(Buffer), BufferLen, VOLUME_NAME_DOS Or FILE_NAME_OPENED)
        
        If ResultLen > 0 And ResultLen <= BufferLen Then
            FinalPath = Left(Buffer, ResultLen)
            ' 转换为SMB格式（替换\\?\UNC\为\\）
            If InStr(FinalPath, "\\?\UNC\") = 1 Then
                FinalPath = "\\" & Mid(FinalPath, 8)
            ElseIf InStr(FinalPath, "\\?\") = 1 Then
                ' 本地路径，直接返回
                FinalPath = Mid(FinalPath, 4)
            End If
            GetTrueNetworkPath = FinalPath
        End If
        
        ' 关闭文件句柄
        CloseHandle hFile
    Else
        GetTrueNetworkPath = "无法获取真实路径"
    End If
End Function

' 使用示例
Sub TestGetSMBPath()
    Dim LocalPath As String
    Dim SMBPath As String
    
    LocalPath = ActiveWorkbook.FullName
    SMBPath = GetTrueNetworkPath(LocalPath)
    
    MsgBox "真实SMB路径：" & SMBPath, vbInformation
End Sub

针对Mac系统 #

在Mac上，可通过VBA调用AppleScript查询文件的原始网络位置，代码如下：

Option Explicit

Function GetMacSMBPath(LocalPath As String) As String
    Dim AppleScriptCode As String
    Dim ScriptResult As String
    
    ' 构造AppleScript代码，查询文件的原始位置
    AppleScriptCode = "set filePath to POSIX file """ & LocalPath & """ as alias" & vbCrLf & _
                      "tell application ""Finder"" to set originalPath to URL of filePath" & vbCrLf & _
                      "return originalPath"
    
    ' 执行AppleScript
    On Error Resume Next
    ScriptResult = MacScript(AppleScriptCode)
    On Error GoTo 0
    
    If ScriptResult <> "" Then
        ' 处理返回的URL格式（smb://xxx...）
        GetMacSMBPath = ScriptResult
    Else
        GetMacSMBPath = "无法获取真实路径"
    End If
End Function

' 使用示例
Sub TestGetMacSMBPath()
    Dim LocalPath As String
    Dim SMBPath As String
    
    LocalPath = ActiveWorkbook.FullName
    SMBPath = GetMacSMBPath(LocalPath)
    
    MsgBox "真实SMB路径：" & SMBPath, vbInformation
End Sub

说明 #

• 上述代码分别适配Windows和Mac系统，根据你的操作系统选择对应的函数调用。
• 调用ActiveWorkbook.Save正常工作的前提是Excel已记录原始网络路径，因此这两个方法可准确提取该路径，无需硬编码。

内容的提问来源于stack exchange，提问作者Oliver Prevost