Windows 资源管理器由 VBA 打开 Shell 命令不在最前面
Windows Explorer Opened by VBA Shell Command Not On Top
我正在使用旧版 MS Access 应用程序，其中实现了“显示文件夹中的文件”功能。
这个函数使用这个基本策略
vPID = Call Shell("explorer.exe /select," & FileFullPathName, vbNormalFocus)
AppActivate vPID
在大多数情况下，这工作正常。但是，我有几个用户抱怨打开的 window 总是落后于其他 windows。所有有此投诉的用户都已将他们的机器修补到最新最好的 Windows 10。我已经能够在类似的机器上复制它。当用户单击“显示文件夹中的文件”按钮时打开多个资源管理器 windows 时，问题最为普遍。
我的各种搜索揭示了几个 Windows API 听起来应该有效的函数（BringWindowToTop、SetForegroundWindow、SwitchToThisWindow（据我所知已弃用）、SetWindowPos、ShowWindow）。我想我了解差异，我应该关注的是 BringWindowToTop。
我对此做了很多测试实现，但是最好总结一下post的内容：.
目前我只是忽略了window 清洁度以及用户可能打开了多少 windows 等等。如果我构建以下内容：
'声明
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function BringWindowToTop Lib "user32" _
(ByVal hWnd As Long) As Long
'Then set the following up in a button
Dim strFile as String
dim strPath as String
dim strPathSplit() as String
dim lngWindow as Long
strFile = "C:\folder1\folder2\folder3\foo.txt"
strPath = "C:\folder1\folder2\folder3\"
strPathSplit = Split(strPath, "\")
Shell "explorer.exe /select," & strFile, vbNormalFocus
lngWindow = FindWindow("CabinetWClass", strPathSplit(UBound(strPathSplit) - 1))
BringWindowToTop lngWindow
AppActivate strPathSplit(UBound(strPathSplit) - 1)
我从 FindWindow 返回一个非零的 window 句柄。但是我用Shell命令打开的资源管理器window却顽固地在后台。它在任务栏上闪烁，但我仍然必须注意到它并单击它才能将其置于顶部。 （当我这样做时它确实打开了。）
我使用其他 Windows API 函数尝试了几种变体并获得了类似的结果。
如果有人能指出我做错了什么，或者指出正确的技术来实现这一点，我将不胜感激。我知道在其他具有类似“显示文件夹中的文件”功能的应用程序中这样做是很有可能的，但我也知道这些是用其他语言编写的，并且可能可以访问我没有的功能。
提前致谢！
您应该使用条件编译来检查您使用的是哪个版本的 Windows 并适当地更改您的声明。 32 位 Windows 处理 Long 类型的方式与 64 位不同：
#If Win64 Then
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As LongPtr) As LongPtr
#Else
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
#End If
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
然后看到您已经有了 window 句柄，您可以使用：
SetForegroundWindow lngWindow
您没有检查来自 BringWindowToTop 的 return 值。你应该那样做。
如果您检查（某些）函数的 return 值，它会告诉您尝试失败。
闪烁的任务栏表示 Window 已被正确通知，但不能被带到顶部，因为 其他一些 window 不会让它出现。
您对文件对话框所做的任何操作 window 都不会将其置于顶部 -- 问题是它没有附加到活动进程。
此处描述了成功的条件：
https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-setforegroundwindow
如果 Office / Win10 被重新设计为具有此行为，解决方案是找到具有前景的进程的句柄，并使用它来创建新对话框，或使用它来释放焦点并将其推到后台，因为两个试图同时在前台的进程是行不通的。
过去这通常是由于用户点击两次而只需要点击一次引起的——抢夺焦点。你应该检查这没有发生。
因此，正如我在上面的一条评论中指出的那样，追求前台进程身份的建议确实解决了我的困境，但不是通过 API 函数我原来打电话的那个。
我最终实现的答案在于 SHOpenFolderAndSelectItems。是的，显然可以这样做 VB/VBA。 fafalone 在 link: https://www.vbforums.com/showthread.php?810301-VB6-Code-Snippet-Open-a-folder-and-select-multiple-files-in-Explorer 上发布了一个现有的实现。我也会在这里复制代码，但正如我所说，它不是我的。
他的函数可以获取文件的完整路径的字符串数组和一个文件夹中的 select 个文件或多个文件夹中的 select 个文件。如果您想为单个文件调用它（就像我正在做的那样），您只需将该文件放入数组中即可。然后使用该字符串数组调用 OpenFolders 子例程。
在下面引用fafalone的代码中，我没有对SierraOscar指出的条件编译进行修改，因为它是直接引用，但我在我的实现中确实这样做了。它似乎确实有所作为。
fafalone 的代码是：
Public Type ResultFolder
sPath As String
sFiles() As String
End Type
Public Declare Function SHOpenFolderAndSelectItems Lib "shell32" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, ByVal dwFlags As Long) As Long
Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Declare Function ILFindLastID Lib "shell32" (ByVal pidl As Long) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Public Sub OpenFolders(sFiles() As String)
If sFiles(0) = "" Then Exit Sub 'caller is responsible for ensuring array has been dim'd and contains valid info
Dim tRes() As ResultFolder
Dim apidl() As Long
Dim ppidl As Long
Dim pidlFQ() As Long
Dim i As Long, j As Long
GetResultsByFolder sFiles, tRes
'Now each entry in tRes is a folder, and its .sFiles member contains every file
'in the original list that is in that folder. So for every folder, we now need to
'create a pidl for the folder itself, and an array of all the relative pidls for the
'files. Two helper APIs replace what used to be tons of pidl-related support
'code before XP. After we've got the pidls, they're handed off to the API
For i = 0 To UBound(tRes)
ReDim apidl(UBound(tRes(i).sFiles))
ReDim pidlFQ(UBound(tRes(i).sFiles))
For j = 0 To UBound(tRes(i).sFiles)
pidlFQ(j) = ILCreateFromPathW(StrPtr(tRes(i).sFiles(j))) 'ILCreateFromPathW gives us Unicode support
apidl(j) = ILFindLastID(pidlFQ(j))
Next
ppidl = ILCreateFromPathW(StrPtr(tRes(i).sPath))
Call SHOpenFolderAndSelectItems(ppidl, UBound(apidl) + 1, VarPtr(apidl(0)), 0&)
'Vista+ has dwFlags to start renaming (single file) or select on desktop; there's no valid flags on XP
'now we need to free all the pidls we created, otherwise it's a memory leak
CoTaskMemFree ppidl
For j = 0 To UBound(pidlFQ)
CoTaskMemFree pidlFQ(j) 'per MSDN, child ids obtained w/ ILFindLastID don't need ILFree, so just free FQ
Next
Next
End Sub
Private Sub GetResultsByFolder(sSelFullPath() As String, tResFolders() As ResultFolder)
Dim i As Long
Dim sPar As String
Dim k As Long, cn As Long, fc As Long
ReDim tResFolders(0)
For i = 0 To UBound(sSelFullPath)
sPar = Left$(sSelFullPath(i), InStrRev(sSelFullPath(i), "\") - 1)
k = RFExists(sPar, tResFolders)
If k >= 0 Then 'there's already a file in this folder, so just add a new file to the folders list
cn = UBound(tResFolders(k).sFiles)
cn = cn + 1
ReDim Preserve tResFolders(k).sFiles(cn)
tResFolders(k).sFiles(cn) = sSelFullPath(i)
Else 'create a new folder entry
ReDim Preserve tResFolders(fc)
ReDim tResFolders(fc).sFiles(0)
tResFolders(fc).sPath = sPar
tResFolders(fc).sFiles(0) = sSelFullPath(i)
fc = fc + 1
End If
Next
End Sub
Private Function RFExists(sPath As String, tResFolders() As ResultFolder) As Long
Dim i As Long
For i = 0 To UBound(tResFolders)
If tResFolders(i).sPath = sPath Then
RFExists = i
Exit Function
End If
Next
RFExists = -1
End Function
我正在使用旧版 MS Access 应用程序，其中实现了“显示文件夹中的文件”功能。
这个函数使用这个基本策略
vPID = Call Shell("explorer.exe /select," & FileFullPathName, vbNormalFocus)
AppActivate vPID
在大多数情况下，这工作正常。但是，我有几个用户抱怨打开的 window 总是落后于其他 windows。所有有此投诉的用户都已将他们的机器修补到最新最好的 Windows 10。我已经能够在类似的机器上复制它。当用户单击“显示文件夹中的文件”按钮时打开多个资源管理器 windows 时，问题最为普遍。
我的各种搜索揭示了几个 Windows API 听起来应该有效的函数（BringWindowToTop、SetForegroundWindow、SwitchToThisWindow（据我所知已弃用）、SetWindowPos、ShowWindow）。我想我了解差异，我应该关注的是 BringWindowToTop。
我对此做了很多测试实现，但是最好总结一下post的内容：
目前我只是忽略了window 清洁度以及用户可能打开了多少 windows 等等。如果我构建以下内容：
'声明
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function BringWindowToTop Lib "user32" _
(ByVal hWnd As Long) As Long
'Then set the following up in a button
Dim strFile as String
dim strPath as String
dim strPathSplit() as String
dim lngWindow as Long
strFile = "C:\folder1\folder2\folder3\foo.txt"
strPath = "C:\folder1\folder2\folder3\"
strPathSplit = Split(strPath, "\")
Shell "explorer.exe /select," & strFile, vbNormalFocus
lngWindow = FindWindow("CabinetWClass", strPathSplit(UBound(strPathSplit) - 1))
BringWindowToTop lngWindow
AppActivate strPathSplit(UBound(strPathSplit) - 1)
我从 FindWindow 返回一个非零的 window 句柄。但是我用Shell命令打开的资源管理器window却顽固地在后台。它在任务栏上闪烁，但我仍然必须注意到它并单击它才能将其置于顶部。 （当我这样做时它确实打开了。）
我使用其他 Windows API 函数尝试了几种变体并获得了类似的结果。
如果有人能指出我做错了什么，或者指出正确的技术来实现这一点，我将不胜感激。我知道在其他具有类似“显示文件夹中的文件”功能的应用程序中这样做是很有可能的，但我也知道这些是用其他语言编写的，并且可能可以访问我没有的功能。
提前致谢！
您应该使用条件编译来检查您使用的是哪个版本的 Windows 并适当地更改您的声明。 32 位 Windows 处理 Long 类型的方式与 64 位不同：
#If Win64 Then
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As LongPtr) As LongPtr
#Else
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
#End If
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
然后看到您已经有了 window 句柄，您可以使用：
SetForegroundWindow lngWindow
您没有检查来自 BringWindowToTop 的 return 值。你应该那样做。 如果您检查（某些）函数的 return 值，它会告诉您尝试失败。
闪烁的任务栏表示 Window 已被正确通知，但不能被带到顶部，因为 其他一些 window 不会让它出现。
您对文件对话框所做的任何操作 window 都不会将其置于顶部 -- 问题是它没有附加到活动进程。
此处描述了成功的条件： https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-setforegroundwindow
如果 Office / Win10 被重新设计为具有此行为，解决方案是找到具有前景的进程的句柄，并使用它来创建新对话框，或使用它来释放焦点并将其推到后台，因为两个试图同时在前台的进程是行不通的。
过去这通常是由于用户点击两次而只需要点击一次引起的——抢夺焦点。你应该检查这没有发生。
因此，正如我在上面的一条评论中指出的那样，追求前台进程身份的建议确实解决了我的困境，但不是通过 API 函数我原来打电话的那个。
我最终实现的答案在于 SHOpenFolderAndSelectItems。是的，显然可以这样做 VB/VBA。 fafalone 在 link: https://www.vbforums.com/showthread.php?810301-VB6-Code-Snippet-Open-a-folder-and-select-multiple-files-in-Explorer 上发布了一个现有的实现。我也会在这里复制代码，但正如我所说，它不是我的。
他的函数可以获取文件的完整路径的字符串数组和一个文件夹中的 select 个文件或多个文件夹中的 select 个文件。如果您想为单个文件调用它（就像我正在做的那样），您只需将该文件放入数组中即可。然后使用该字符串数组调用 OpenFolders 子例程。
在下面引用fafalone的代码中，我没有对SierraOscar指出的条件编译进行修改，因为它是直接引用，但我在我的实现中确实这样做了。它似乎确实有所作为。
fafalone 的代码是：
Public Type ResultFolder
sPath As String
sFiles() As String
End Type
Public Declare Function SHOpenFolderAndSelectItems Lib "shell32" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, ByVal dwFlags As Long) As Long
Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Declare Function ILFindLastID Lib "shell32" (ByVal pidl As Long) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Public Sub OpenFolders(sFiles() As String)
If sFiles(0) = "" Then Exit Sub 'caller is responsible for ensuring array has been dim'd and contains valid info
Dim tRes() As ResultFolder
Dim apidl() As Long
Dim ppidl As Long
Dim pidlFQ() As Long
Dim i As Long, j As Long
GetResultsByFolder sFiles, tRes
'Now each entry in tRes is a folder, and its .sFiles member contains every file
'in the original list that is in that folder. So for every folder, we now need to
'create a pidl for the folder itself, and an array of all the relative pidls for the
'files. Two helper APIs replace what used to be tons of pidl-related support
'code before XP. After we've got the pidls, they're handed off to the API
For i = 0 To UBound(tRes)
ReDim apidl(UBound(tRes(i).sFiles))
ReDim pidlFQ(UBound(tRes(i).sFiles))
For j = 0 To UBound(tRes(i).sFiles)
pidlFQ(j) = ILCreateFromPathW(StrPtr(tRes(i).sFiles(j))) 'ILCreateFromPathW gives us Unicode support
apidl(j) = ILFindLastID(pidlFQ(j))
Next
ppidl = ILCreateFromPathW(StrPtr(tRes(i).sPath))
Call SHOpenFolderAndSelectItems(ppidl, UBound(apidl) + 1, VarPtr(apidl(0)), 0&)
'Vista+ has dwFlags to start renaming (single file) or select on desktop; there's no valid flags on XP
'now we need to free all the pidls we created, otherwise it's a memory leak
CoTaskMemFree ppidl
For j = 0 To UBound(pidlFQ)
CoTaskMemFree pidlFQ(j) 'per MSDN, child ids obtained w/ ILFindLastID don't need ILFree, so just free FQ
Next
Next
End Sub
Private Sub GetResultsByFolder(sSelFullPath() As String, tResFolders() As ResultFolder)
Dim i As Long
Dim sPar As String
Dim k As Long, cn As Long, fc As Long
ReDim tResFolders(0)
For i = 0 To UBound(sSelFullPath)
sPar = Left$(sSelFullPath(i), InStrRev(sSelFullPath(i), "\") - 1)
k = RFExists(sPar, tResFolders)
If k >= 0 Then 'there's already a file in this folder, so just add a new file to the folders list
cn = UBound(tResFolders(k).sFiles)
cn = cn + 1
ReDim Preserve tResFolders(k).sFiles(cn)
tResFolders(k).sFiles(cn) = sSelFullPath(i)
Else 'create a new folder entry
ReDim Preserve tResFolders(fc)
ReDim tResFolders(fc).sFiles(0)
tResFolders(fc).sPath = sPar
tResFolders(fc).sFiles(0) = sSelFullPath(i)
fc = fc + 1
End If
Next
End Sub
Private Function RFExists(sPath As String, tResFolders() As ResultFolder) As Long
Dim i As Long
For i = 0 To UBound(tResFolders)
If tResFolders(i).sPath = sPath Then
RFExists = i
Exit Function
End If
Next
RFExists = -1
End Function