如何通过VBA获取Dropbox目录以适配团队升级后的路径变更？

Dropbox for Teams将于2022年12月10日完成升级，路径命名规则将发生以下变化：

• 个人Dropbox目录：从Dropbox (me)变更为me (Dropbox)
• 团队Dropbox目录：从Dropbox [team name]变更为[Team name] Dropbox

现有VBA代码采用硬编码路径：

fromPath = "C:\Dropbox (me)\Development\" + aDir + "\"

我们可以实现getDropBoxPath()函数，让代码兼容升级前后的路径格式，修改后代码如下：

fromPath = getDropBoxPath() + "\Development\" + aDir + "\"

方案一：文件夹检测版（简单快速） #

通过检测系统中是否存在新/旧格式的Dropbox目录，自动返回有效路径：

Function getDropBoxPath() As String
    Dim driveLetter As String
    Dim oldPersonalPath As String, newPersonalPath As String
    Dim oldTeamPath As String, newTeamPath As String
    Dim teamName As String
    
    ' 指定Dropbox所在盘符，可根据实际调整
    driveLetter = "C:\"
    
    ' 检测个人路径
    oldPersonalPath = driveLetter & "Dropbox (me)"
    newPersonalPath = driveLetter & "me (Dropbox)"
    
    If Dir(newPersonalPath, vbDirectory) <> "" Then
        getDropBoxPath = newPersonalPath
        Exit Function
    ElseIf Dir(oldPersonalPath, vbDirectory) <> "" Then
        getDropBoxPath = oldPersonalPath
        Exit Function
    End If
    
    ' 检测团队路径（替换为你的实际团队名称）
    teamName = "YourTeamName"
    oldTeamPath = driveLetter & "Dropbox [" & teamName & "]"
    newTeamPath = driveLetter & teamName & " Dropbox"
    
    If Dir(newTeamPath, vbDirectory) <> "" Then
        getDropBoxPath = newTeamPath
        Exit Function
    ElseIf Dir(oldTeamPath, vbDirectory) <> "" Then
        getDropBoxPath = oldTeamPath
        Exit Function
    End If
    
    ' 未找到路径时的处理
    getDropBoxPath = ""
    MsgBox "未找到有效Dropbox路径，请检查路径配置", vbExclamation
End Function

方案二：读取Dropbox配置文件版（更可靠） #

Dropbox会在本地%APPDATA%\Dropbox\info.json文件中存储实际路径信息，读取该文件可自动适配所有场景，无需硬编码盘符或团队名：

Function getDropBoxPath() As String
    Dim fso As Object
    Dim jsonPath As String
    Dim jsonContent As String
    Dim fileNum As Integer
    Dim personalPath As String, teamPath As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 定位Dropbox配置文件
    jsonPath = Environ("APPDATA") & "\Dropbox\info.json"
    
    If Not fso.FileExists(jsonPath) Then
        MsgBox "未找到Dropbox配置文件", vbExclamation
        getDropBoxPath = ""
        Exit Function
    End If
    
    ' 读取配置文件内容
    fileNum = FreeFile
    Open jsonPath For Input As #fileNum
    jsonContent = Input$(LOF(fileNum), fileNum)
    Close #fileNum
    
    ' 优先提取个人路径
    personalPath = ExtractPathFromJson(jsonContent, """path"": """, """", "personal")
    If personalPath <> "" Then
        getDropBoxPath = personalPath
        Exit Function
    End If
    
    ' 提取团队路径
    teamPath = ExtractPathFromJson(jsonContent, """path"": """, """", "team")
    If teamPath <> "" Then
        getDropBoxPath = teamPath
        Exit Function
    End If
    
    getDropBoxPath = ""
    MsgBox "无法从配置文件中提取Dropbox路径", vbExclamation
End Function

' 辅助函数：从JSON片段中提取路径
Function ExtractPathFromJson(jsonStr As String, startMarker As String, endMarker As String, section As String) As String
    Dim sectionStart As Long, sectionEnd As Long
    Dim pathStart As Long, pathEnd As Long
    
    ' 定位目标区块（personal/team）
    sectionStart = InStr(jsonStr, """ & section & """: {")
    If sectionStart = 0 Then
        ExtractPathFromJson = ""
        Exit Function
    End If
    
    ' 定位区块结束位置
    sectionEnd = InStr(sectionStart, jsonStr, "}")
    If sectionEnd = 0 Then
        ExtractPathFromJson = ""
        Exit Function
    End If
    
    ' 在区块内定位路径字符串
    pathStart = InStr(sectionStart, jsonStr, startMarker)
    If pathStart = 0 Or pathStart > sectionEnd Then
        ExtractPathFromJson = ""
        Exit Function
    End If
    pathStart = pathStart + Len(startMarker)
    
    pathEnd = InStr(pathStart, jsonStr, endMarker)
    If pathEnd = 0 Or pathEnd > sectionEnd Then
        ExtractPathFromJson = ""
        Exit Function
    End If
    
    ' 替换JSON中的转义斜杠
    ExtractPathFromJson = Replace(Mid(jsonStr, pathStart, pathEnd - pathStart), "\\", "\")
End Function

说明 #

• 方案一适合快速验证，需要手动指定盘符和团队名称
• 方案二更健壮，自动适配个人/团队场景，以及升级前后的路径格式变化

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