Fatal编程技术网
  • vba/
  • Vba 下载XMLHTTP60文件后，将焦点返回到此工作簿.Activesheet

Vba 下载XMLHTTP60文件后，将焦点返回到此工作簿.Activesheet

vba excel web-scraping

Vba 下载XMLHTTP60文件后，将焦点返回到此工作簿.Activesheet,vba,excel,web-scraping,focus,Vba,Excel,Web Scraping,Focus,情况： 启动文件下载后，我无法将焦点返回Excel应用程序 我通常的AppActivate和Application.hwnd技巧在应用程序之间工作时，这次似乎不起作用。我以前在这方面没有遇到过问题，所以不知道我今天是否特别密集，或者，这是因为我第一次使用浏览器。我怀疑是前者 问题: 1） 有人能看出我哪里出了问题吗（为什么焦点不移回Excel） 2） 更重要的是：有没有一种方法可以在后台下载文件，使用默认浏览器，将注意力集中在此工作簿上，从而完全避免此问题 目前，我在下载后立即使用SendKey

情况：

启动文件下载后，我无法将焦点返回Excel应用程序

我通常的
AppActivate
和
Application.hwnd
技巧在应用程序之间工作时，这次似乎不起作用。我以前在这方面没有遇到过问题，所以不知道我今天是否特别密集，或者，这是因为我第一次使用浏览器。我怀疑是前者

问题:

1） 有人能看出我哪里出了问题吗（为什么焦点不移回Excel）

2） 更重要的是：有没有一种方法可以在后台下载文件，使用默认浏览器，将注意力集中在
此工作簿上，从而完全避免此问题

目前，我在下载后立即使用
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
使用窗口中实际显示的标题：


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） 最后，我的代码的当前版本使用@的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


其他参考资料：

(一)

2） )；链接也在主体中

(三)

(四)


5） 感谢@OmegaStripes和他们的投入

使用@OmegaStripes建议的方法一：


  • 使用XMLHTTP获取二进制响应内容
    • 

  • 转换为UTF-8
    • 

  • 解析以提取所需的URL
    • 

  • 使用新的XMLHTTP下载二进制文件
    • 

  • 使用ADODB.Stream写出文件
    • 
效果很好，焦点转移没有问题
    
注意：对于步骤3，我使用了by的方法将字符串（转换后的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

    

    感谢@OmegaStripes和他们的投入
    
使用@OmegaStripes建议的方法一：
    

  • 使用XMLHTTP获取二进制响应内容
    • 

  • 转换为UTF-8
    • 

  • 解析以提取所需的URL
    • 

  • 使用新的XMLHTTP下载二进制文件
    • 

  • 使用ADODB.Stream写出文件
    • 
效果很好，焦点转移没有问题
    
注意：对于步骤3，我使用了by的方法将字符串（转换后的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

    

    
总之，更改此项：
    

    AppActivate "Microsoft Excel"

    
到
    
注意：命令前的暂停可能会有所帮助（至少在我的情况下）：
    

    
总之，更改此项：
    

    AppActivate "Microsoft Excel"

    
到
    
注意：命令前的暂停可能会有所帮助（至少在我的情况下）：
    

    一般来说，这里不需要
    HTMLDocument
    ，因此Excel不会失去焦点。尝试通过简单拆分（检查或）从解析它的响应中提取文件下载URL，然后制作另一个XHR以下载目标文件内容，并使用
    ADODB.Stream
    （检查）保存它。@omegastripes感谢您的帮助。太多的阅读让你无法理解你的本来面目，但却达到了目的。非常感谢。那么，你想出密码了吗？如果能用有效的解决方案来回答这个问题，那就太好了。@Omegas，我确实这样做了，不过实际上是为了一个不同的场景。使用了您的过程，所以我可以，也许今天晚些时候，适应用作此问题的答案。现在已发布。通常，您不需要
    HTMLDocument
    ，因此Excel不会失去焦点。尝试通过简单拆分（检查或）从解析它的响应中提取文件下载URL，然后制作另一个XHR以下载目标文件内容，并使用
    ADODB.Stream
    （检查）保存它。@omegastripes感谢您的帮助。太多的阅读让你无法理解你的本来面目，但却达到了目的。非常感谢。那么，你想出密码了吗？如果能用有效的解决方案来回答这个问题，那就太好了。@Omegas，我确实这样做了，不过实际上是为了一个不同的场景。使用了你的过程，所以我可以，也许今天晚些时候，适应使用作为这个问题的答案。我现在已经发布了。我认为这给我带来了同样的问题，尽管这在过去很有用+1 AppActivate应该使用窗口标题中的内容，但它有缺陷。我认为这给我带来了同样的问题，尽管这在过去很有用+1 AppActivate应该使用窗口标题中的内容，但它有缺陷。