下载XMLHTTP60文件后，将焦点返回到ThisWorkbook.Activesheet [英] Return focus to ThisWorkbook.Activesheet after XMLHTTP60 file download
问题描述
情况:
启动文件下载后，我无法将焦点返回到Excel应用程序.
I am unable to return focus to the Excel application after initiating a file download.
我通常的 AppActivate 和 Application.hwnd 技巧，在应用程序之间工作时，这次似乎不起作用.之前我没有遇到任何问题，所以不知道我今天是否特别密集，或者是因为我是第一次使用浏览器.我怀疑是前者.
My usual tricks of AppActivate and Application.hwnd , when working between applications, don't seem to be working this time. I haven't had a problem doing this before so don't know if I am being particularly dense today, or, it is because I am involving a browser for the first time. I suspect it is the former.
问题:
1)谁能看到我要去的地方(为什么焦点没有移回到Excel上)?
1) Can any one see where I am going wrong (why focus does not shift back to Excel)?
2)更重要的是:是否有一种方法可以使用默认浏览器在后台下载文件，将重点放在 ThisWorkbook 上，从而完全避免出现此问题?
2) More importantly: Is there a way to download files in the background, using the default browser, keeping the focus on ThisWorkbook and thereby avoiding the issue altogether?
下载后，我立即使用了 SendKeys％{F4}" 的解决方法，目前，它关闭了浏览器，因此默认恢复为Excel.
I am using a workaround of SendKeys "%{F4}" immediately after the download, at present, to close the browser and so am defaulting back to Excel.
注意:在我的情况下，默认浏览器是Google Chrome，但显然可以是任何浏览器.
Note: The default browser in my case is Google Chrome but clearly could be any browser.
我尝试过的事情:
1)来自@ user1452705 ;重点没有转移:
1) From @user1452705; focus didn't shift:
Public Declare Function SetForegroundWindow _
Lib "user32" (ByVal hwnd As Long) As Long
Public Sub Bring_to_front()
Dim setFocus As Long
ThisWorkbook.Worksheets("Sheet1").Activate
setfocus = SetForegroundWindow(Application.hwnd)
End Sub
2)然后我尝试了:
ThisWorkbook.Activate 'No shift in focus
Windows(ThisWorkbook.Name).Activate 'Nothing happened
Application.Windows(ThisWorkbook.Name & " - Excel").Activate 'Subscript out of range
3)使用实际显示在窗口中的标题来 AppActivate :
3) AppActivate using Title as actually displayed in Window:
AppActivate "AmbSYS_testingv14.xlsm" & " - Excel" 'Nothing happened
4)更加绝望的尝试:
4) More desperate attempts:
AppActivate Application.Caption 'Nothing happened
AppActivate ThisWorkbook.Name & " - Excel" 'Nothing happened
AppActivate ThisWorkbook.Name 'Nothing happened
AppActivate "Microsoft Excel" 'Invalid proc call
4)最后，我代码的当前版本使用@ ChipPearson '子 ActivateExcel ，它也无效:
4) Finally, the current version of my code is using @ChipPearson's sub ActivateExcel , which also has no effect:
模块1:
Public Sub DownloadFiles()
'Tools > ref> MS XML and HTML Object lib
Dim http As XMLHTTP60
Dim html As HTMLDocument
Set http = New XMLHTTP60
Set html = New HTMLDocument
With http
.Open "GET", "https://www.england.nhs.uk/statistics/statistical-work-areas/ambulance-quality-indicators/ambulance-quality-indicators-data-2017-18/", False
.send
html.body.innerHTML = .responseText
End With
'Test Download code
html.getElementsByTagName("p")(4).getElementsByTagName("a")(0).Click
' Application.Wait Now + TimeSerial(0, 0, 3) 'pause for downloads to finish before files
'Other code
ActivateExcel
End Sub
模块2:
Option Explicit
Option Compare Text
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modActivateExcel
' By Chip Pearson, www.cpearson.com, chip@cpearson.com
' http://www.cpearson.com/excel/ActivateExcelMain.aspx
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Window API Declarations
' These Declares MUST appear at the top of the
' code module, above and before any VBA procedures.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare PtrSafe Function BringWindowToTop Lib "user32" ( _
ByVal HWnd As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SetFocus Lib "user32" ( _
ByVal HWnd As Long) As Long
Public Sub ActivateExcel()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ActivateExcel
' This procedure activates the main Excel application window,
' ("XLMAIN") moving it to the top of the Z-Order and sets keyboard
' focus to Excel.
'
' !!!!!!!!!!!!!!!!!!!!!!!!!
' NOTE: This will not work properly if a VBA Editor is open.
' If a VBA Editor window is open, the system will set focus
' to that window, rather than the XLMAIN window.
' !!!!!!!!!!!!!!!!!!!!!!!!!
'
' This code should be able to activate the main window of any
' application whose main window class name is known. Just change
' the value of C_MAIN_WINDOW_CLASS to the window class of the
' main application window (e.g., "OpusApp" for Word).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Res As Long ' General purpose Result variable
Dim XLHWnd As Long ' Window handle of Excel
Const C_MAIN_WINDOW_CLASS = "XLMAIN"
'''''''''''''''''''''''''''''''''''''''''''
' Get the window handle of the main
' Excel application window ("XLMAIN"). If
' more than one instance of Excel is running,
' you have no control over which
' instance's HWnd will be retrieved.
' Related Note: You MUST use vbNullString
' not an empty string "" in the call to
' FindWindow. When calling API functions
' there is a difference between vbNullString
' and an empty string "".
''''''''''''''''''''''''''''''''''''''''''
XLHWnd = FindWindow(lpClassName:=C_MAIN_WINDOW_CLASS, _
lpWindowName:=vbNullString)
If XLHWnd > 0 Then
'''''''''''''''''''''''''''''''''''''''''
' If HWnd is > 0, FindWindow successfully
' found the Excel main application window.
' Move XLMAIN to the top of the
' Z-Order.
'''''''''''''''''''''''''''''''''''''''''
Res = BringWindowToTop(HWnd:=XLHWnd)
If Res = 0 Then
Debug.Print "Error With BringWindowToTop: " & _
CStr(Err.LastDllError)
Else
'''''''''''''''''''''''''''''''''
' No error.
' Set keyboard input focus XLMAIN
'''''''''''''''''''''''''''''''''
SetFocus HWnd:=XLHWnd
End If
Else
'''''''''''''''''''''''''''''''''
' HWnd was 0. FindWindow couldn't
' find Excel.
'''''''''''''''''''''''''''''''''
Debug.Print "Can't find Excel"
End If
End Sub
其他参考:
2) VBA API声明.无论使用什么应用程序，都可以将窗口置于最前面；还在主体中链接
2) VBA API declarations. Bring window to front , regardless of application ; link also in main body
5)推荐答案
Thanks to @OmegaStripes and @FlorentB for their input. 使用@OmegaStripes建议的方法I: Using @OmegaStripes suggested method I: 使用XMLHTTP获取二进制响应内容 Use XMLHTTP to get binary response content 转换为UTF-8 解析以提取所需的URL Parse to extract the required URL 使用新的XMLHTTP下载二进制 Use a new XMLHTTP to download binary 使用ADODB.Stream写入文件 Use ADODB.Stream to write out file 请客，重点转移没有问题. Works a treat and no problems with shift in focus. 注意:对于第3步，我通过 @KarstenW使用了该方法将字符串(转换后的responseText字符串)写到txt文件中，以进行检查，以确定如何访问感兴趣的URL. Notes: For step 3, I used the approach by @KarstenW to write the string , the converted responseText string, out to a txt file for examination to determine how to access the URL of interest. 这篇关于下载XMLHTTP60文件后，将焦点返回到ThisWorkbook.Activesheet的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
Option Explicit
Public Const adSaveCreateOverWrite As Byte = 2
Public Const url As String = "https://www.england.nhs.uk/statistics/statistical-work-areas/ambulance-quality-indicators/ambulance-quality-indicators-data-2017-18/"
Public Const adTypeBinary As Byte = 1
Public Const adTypeText As Byte = 2
Public Const adModeReadWrite As Byte = 3
Public Sub DownLoadFiles()
Dim downLoadURL As String
Dim aBody As String
' Download via XHR
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", url, False
.send
' Get binary response content
aBody = BytesToString(.responseBody, "UTF-8")
End With
Dim respTextArr() As String
respTextArr = Split(Split(aBody, "New AmbSYS Indicators")(0))
downLoadURL = Split(respTextArr(UBound(respTextArr)), Chr$(34))(1)
Dim urlArr() As String
Dim fileName As String
Dim bBody As Variant
Dim sPath As String
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", downLoadURL, False
.send
urlArr = Split(downLoadURL, "/")
fileName = urlArr(UBound(urlArr))
bBody = .responseBody
sPath = ThisWorkbook.Path & "\" & fileName
End With
' Save binary content to the xls file
With CreateObject("ADODB.Stream")
.Type = 1
.Open
.Write bBody
.SaveToFile sPath, adSaveCreateOverWrite
.Close
End With
' Open saved workbook
With Workbooks.Open(sPath, , False)
End With
End Sub
Public Function BytesToString(ByVal bytes As Variant, ByVal charset As String) As String
With CreateObject("ADODB.Stream")
.Mode = adModeReadWrite
.Type = adTypeBinary
.Open
.Write bytes
.Position = 0
.Type = adTypeText
.charset = charset
BytesToString = .ReadText
End With
End Function
