VBA调用Shell命令打开Windows资源管理器窗口无法置顶问题求助

核心原因 #

Windows 10及以上版本内置前台进程权限限制：仅当前正在与用户交互的前台进程，有权限将其他窗口强制置顶到上层，后台进程调用BringWindowToTop、SetForegroundWindow这类API时，只会触发任务栏闪烁，不会真正完成置顶操作，这是系统为防止程序恶意抢占焦点做的默认限制，并非API调用逻辑错误。

现有代码存在的问题 #

1. 调用Shell后无等待逻辑，直接执行FindWindow时，explorer.exe的新窗口还未完成初始化，拿到的大概率是已存在的同路径旧窗口句柄，并非刚打开的目标窗口。
2. 未处理系统前台权限限制，直接调用置顶API没有操作权限。

可直接使用的修复方案 #

首先补充兼容32/64位Access的API声明：

' 32/64位兼容API声明
#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As LongPtr, ByRef lpdwProcessId As Long) As Long
    Private Declare PtrSafe Function AttachThreadInput Lib "user32" (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, ByRef lpdwProcessId As Long) As Long
    Private Declare Function AttachThreadInput Lib "user32" (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long
#End If

Private Const SW_RESTORE As Long = 9
Private Const SW_SHOW As Long = 5

然后替换按钮点击事件逻辑：

Dim strFile As String
Dim strPath As String
Dim strPathSplit() As String
#If VBA7 Then
    Dim lngWindow As LongPtr
#Else
    Dim lngWindow As Long
#End If
Dim currentThreadId As Long
Dim targetThreadId As Long
Dim i As Integer
Dim folderName As String

strFile = "C:\folder1\folder2\folder3\foo.txt"
strPath = "C:\folder1\folder2\folder3\"
strPathSplit = Split(strPath, "\")
folderName = strPathSplit(UBound(strPathSplit) - 1)

' 启动资源管理器定位目标文件
Shell "explorer.exe /select," & strFile, vbNormalFocus

' 循环等待目标窗口加载完成，最多等待3秒兼容低配置设备
For i = 1 To 30
    Sleep 100
    lngWindow = FindWindow("CabinetWClass", folderName)
    If lngWindow <> 0 Then Exit For
Next i

If lngWindow = 0 Then
    ' 可自行补充窗口未找到的容错逻辑
    Exit Sub
End If

' 绑定线程输入队列，绕过系统前台权限限制
currentThreadId = GetCurrentThreadId()
targetThreadId = GetWindowThreadProcessId(lngWindow, 0)
AttachThreadInput currentThreadId, targetThreadId, True

' 执行窗口恢复、置顶操作
ShowWindow lngWindow, SW_RESTORE
ShowWindow lngWindow, SW_SHOW
SetForegroundWindow lngWindow

' 解绑线程输入队列
AttachThreadInput currentThreadId, targetThreadId, False

补充说明 #

• 如果用户的资源管理器设置了「标题栏显示完整路径」，需要将FindWindow的第二个参数替换为完整路径，或者改用枚举所有资源管理器窗口匹配路径的逻辑，兼容性更强。
• 64位版本Access必须使用带PtrSafe标识的API声明，否则会出现编译错误。

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