求助：获取Dropbox中共享Excel工作簿的当前在线用户列表代码

Excel自带的Application.UserStatus仅支持官方共享工作簿模式，而Dropbox是通过文件实时同步实现多人编辑，每个用户打开的都是本地同步副本，因此该方法无法识别其他在线用户。下面提供基于临时标记文件+VBA的可行方案：

核心思路 #

利用Dropbox实时同步特性，每个用户打开工作簿时，在同目录下创建一个唯一的临时标记文件；关闭工作簿时删除该文件。通过读取所有存在的标记文件，即可获取当前所有在线用户列表。

VBA代码实现 #

1. 工作簿打开事件（ThisWorkbook模块） #

Private Sub Workbook_Open()
    Dim sessionFolder As String
    Dim userFile As String
    Dim userName As String
    Dim computerName As String
    
    ' 获取当前用户名和电脑名（确保标记文件唯一）
    userName = Application.UserName
    computerName = Environ("COMPUTERNAME")
    
    ' 定义标记文件存储目录（与工作簿同目录下的UserSessions文件夹）
    sessionFolder = ThisWorkbook.Path & "\UserSessions\"
    
    ' 若目录不存在则创建
    If Dir(sessionFolder, vbDirectory) = "" Then
        MkDir sessionFolder
    End If
    
    ' 定义当前用户的标记文件名
    userFile = sessionFolder & userName & "_" & computerName & ".txt"
    
    ' 创建标记文件（写入用户信息）
    Open userFile For Output As #1
    Print #1, "在线用户：" & userName & "（设备：" & computerName & "）"
    Close #1
    
    ' 首次刷新用户列表
    RefreshUserList
    
    ' 设置定时刷新（每30秒刷新一次，可调整）
    Application.OnTime Now + TimeValue("00:00:30"), "RefreshUserList"
End Sub

2. 工作簿关闭事件（ThisWorkbook模块） #

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim sessionFolder As String
    Dim userFile As String
    Dim userName As String
    Dim computerName As String
    
    userName = Application.UserName
    computerName = Environ("COMPUTERNAME")
    sessionFolder = ThisWorkbook.Path & "\UserSessions\"
    userFile = sessionFolder & userName & "_" & computerName & ".txt"
    
    ' 删除当前用户的标记文件
    If Dir(userFile) <> "" Then
        Kill userFile
    End If
    
    ' 清理定时任务
    On Error Resume Next
    Application.OnTime Now + TimeValue("00:00:30"), "RefreshUserList", , False
End Sub

3. 用户列表刷新宏（标准模块） #

Sub RefreshUserList()
    Dim sessionFolder As String
    Dim userFiles As String
    Dim userInfo As String
    Dim outputRange As Range
    Dim rowNum As Integer
    
    ' 指定显示用户列表的单元格区域（例如Sheet1的A2开始，可自行修改）
    Set outputRange = ThisWorkbook.Sheets("Sheet1").Range("A2")
    
    ' 清空原有列表
    outputRange.CurrentRegion.ClearContents
    outputRange.Value = "当前在线用户："
    
    sessionFolder = ThisWorkbook.Path & "\UserSessions\"
    userFiles = Dir(sessionFolder & "*.txt")
    
    rowNum = 2 ' 从第二行开始显示用户（第一行是标题）
    
    ' 遍历所有标记文件，读取用户信息
    Do While userFiles <> ""
        Open sessionFolder & userFiles For Input As #1
        Line Input #1, userInfo
        Close #1
        
        ' 将用户信息写入单元格
        outputRange.Offset(rowNum - 1, 0).Value = userInfo
        rowNum = rowNum + 1
        
        userFiles = Dir
    Loop
    
    ' 再次设置定时刷新
    Application.OnTime Now + TimeValue("00:00:30"), "RefreshUserList"
End Sub

设置说明 #

1. 打开Excel工作簿，按Alt+F11打开VBA编辑器
2. 将上述代码分别粘贴到ThisWorkbook模块（打开/关闭事件）和新建的标准模块（RefreshUserList宏）
3. 修改RefreshUserList中的outputRange参数，指定你需要显示用户列表的单元格位置
4. 确保所有使用该工作簿的用户都启用宏（文件另存为.xlsm格式，打开时启用宏）
5. Dropbox需保持后台同步正常，确保标记文件能实时同步

注意事项 #

• 若用户异常关闭Excel（如崩溃），标记文件可能无法自动删除，可定期手动清理UserSessions文件夹
• 用户名+电脑名的组合可避免同一用户在多台设备登录时的冲突

内容的提问来源于stack exchange，提问作者C.Price