Return XMLHTTP60 文件下载后聚焦到 ThisWorkbook.Activesheet
Return focus to ThisWorkbook.Activesheet after XMLHTTP60 file download
情况：
我无法在启动文件下载后 return 专注于 Excel 应用程序。
我常用的 AppActivate 和 Application.hwnd 技巧，在应用程序之间工作时，这次似乎不起作用。我以前没有遇到过这个问题所以不知道我今天是不是特别密集，或者，这是因为我第一次涉及浏览器。我怀疑是前者。
问题：
1) 谁能看出我哪里出错了（为什么焦点没有移回 Excel）？
2) 更重要的是：有没有办法在后台下载文件，使用默认浏览器，将注意力集中在 ThisWorkbook 上，从而完全避免这个问题？
我在下载后立即使用 SendKeys "%{F4}" 的解决方法，目前，关闭浏览器，因此默认返回 Excel。
注意：我的默认浏览器是 Google Chrome 但显然可以是任何浏览器。
我尝试过的：
1) 来自@；焦点没有转移：
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 使用 Window 中实际显示的标题：
AppActivate "AmbSYS_testingv14.xlsm" & " - Excel" 'Nothing happened
4）更绝望的尝试：
AppActivate Application.Caption 'Nothing happened
AppActivate ThisWorkbook.Name & " - Excel" 'Nothing happened
AppActivate ThisWorkbook.Name 'Nothing happened
AppActivate "Microsoft Excel" 'Invalid proc call
4) 最后，我的代码的当前版本使用的是@ChipPearson 的 sub ActivateExcel ，它也没有效果：
模块 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
其他参考资料：
1) Toggle between Excel and IE
2) ; link 也在主要 body
3) Return focus to excel after finishing downloading file with Internet explorer
4)
感谢@OmegaStripes 和 的输入。
使用@OmegaStripes 建议的方法 I:
使用XMLHTTP获取二进制响应内容
转换为 UTF-8
解析提取需要的URL
使用新的 XMLHTTP 下载二进制文件
使用ADODB.Stream写出文件
工作愉快，焦点转移没有问题。
注意：对于第3步，我使用@KarstenW的方法将字符串，即转换后的responseText字符串写入一个txt文件进行检查，以确定如何访问URL的兴趣。
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
For Excel 2013 please see here a solution that worked for me
总而言之，更改为：
AppActivate "Microsoft Excel"
到
AppActivate "Excel
注意：命令前的暂停会有帮助（至少对我而言）：
Application.Wait (Now + TimeValue("0:00:1"))
情况：
我无法在启动文件下载后 return 专注于 Excel 应用程序。
我常用的 AppActivate 和 Application.hwnd 技巧，在应用程序之间工作时，这次似乎不起作用。我以前没有遇到过这个问题所以不知道我今天是不是特别密集，或者，这是因为我第一次涉及浏览器。我怀疑是前者。
问题：
1) 谁能看出我哪里出错了（为什么焦点没有移回 Excel）？
2) 更重要的是：有没有办法在后台下载文件，使用默认浏览器，将注意力集中在 ThisWorkbook 上，从而完全避免这个问题？
我在下载后立即使用 SendKeys "%{F4}" 的解决方法，目前，关闭浏览器，因此默认返回 Excel。
注意：我的默认浏览器是 Google Chrome 但显然可以是任何浏览器。
我尝试过的：
1) 来自@
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 使用 Window 中实际显示的标题：
AppActivate "AmbSYS_testingv14.xlsm" & " - Excel" 'Nothing happened
4）更绝望的尝试：
AppActivate Application.Caption 'Nothing happened
AppActivate ThisWorkbook.Name & " - Excel" 'Nothing happened
AppActivate ThisWorkbook.Name 'Nothing happened
AppActivate "Microsoft Excel" 'Invalid proc call
4) 最后，我的代码的当前版本使用的是@ChipPearson 的 sub ActivateExcel ，它也没有效果：
模块 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
其他参考资料：
1) Toggle between Excel and IE
2)
3) Return focus to excel after finishing downloading file with Internet explorer
4)
感谢@OmegaStripes 和
使用@OmegaStripes 建议的方法 I:
使用XMLHTTP获取二进制响应内容
转换为 UTF-8
解析提取需要的URL
使用新的 XMLHTTP 下载二进制文件
使用ADODB.Stream写出文件
工作愉快，焦点转移没有问题。
注意：对于第3步，我使用@KarstenW的方法将字符串，即转换后的responseText字符串写入一个txt文件进行检查，以确定如何访问URL的兴趣。
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
For Excel 2013 please see here a solution that worked for me
总而言之，更改为：
AppActivate "Microsoft Excel"
到
AppActivate "Excel
注意：命令前的暂停会有帮助（至少对我而言）：
Application.Wait (Now + TimeValue("0:00:1"))