VBA-从Internet Explorer的框架通知栏中选择另存为 [英] VBA - choose save as from the frame notification bar of internet explorer

问题描述

我正在尝试通过Internet Explorer的框架通知栏下载另存为的文件. 但是，在进行大量搜索之后，我只找到了在框架通知栏上单击save的解决方案. 到目前为止，我一直试图将其另存为示例站点中的文件:

I am trying to download a file with save as through the frame notification bar of internet explorer. However after doing a lot of searches, I have only found solutions to click save on the frame notification bar. So far I have been trying to save as the file on the sample site:

http://www.tvsubtitles.net/subtitle-114117.html

具有以下代码:

' Add referenses
' Microsoft Internet Controls
' Microsoft HTML Object Library
' UIAutomationClient (copy file from C:\Windows\System32\UIAutomationCore.dll to Documents Folder)

#If VBA7 Then
    Private Declare PtrSafe Function FindWindowEx _
        Lib "user32" _
        Alias "FindWindowExA" ( _
        ByVal hWnd1 As LongPtr, _
        ByVal hWnd2 As LongPtr, _
        ByVal lpsz1 As String, _
        ByVal lpsz2 As String) _
        As LongPtr
#Else
    Private Declare Function FindWindowEx _
        Lib "user32" _
        Alias "FindWindowExA" ( _
        ByVal hWnd1 As Long, _
        ByVal hWnd2 As Long, _
        ByVal lpsz1 As String, _
        ByVal lpsz2 As String) _
        As Long
 #End If

Sub downloadfilefromeie()

    Dim subpage As InternetExplorer
    Dim objpage As HTMLDocument
    Dim o As CUIAutomation
    Dim h As LongPtr
    Dim fnb As LongPtr
    Dim e As IUIAutomationElement
    Dim iCnd As IUIAutomationCondition
    Dim Button As IUIAutomationElement
    Dim InvokePattern As IUIAutomationInvokePattern
    Dim strBuff As String
    Dim ButCap As String

    Set objshell = CreateObject("Shell.Application")
    Set objallwindows = objshell.Windows
    Set subpage = New InternetExplorer
    For Each ow In objallwindows
        'MsgBox ow
        If (InStr(1, ow, "Internet Explorer", vbTextCompare)) Then
            'MsgBox ow.Hwnd & "  " & ow & "   " & ow.locationURL
            If (InStr(1, ow.locationURL, "tvsub", vbTextCompare)) Then
                Set subpage = ow
            End If
        End If
    Next
    Set objpage = New HTMLDocument
    If subpage Is Nothing Then
    Else
        Set objpage = subpage.Document
        'Debug.Print objpage
        'objpage.getElementById("content").Click
        Set dl = objpage.getElementsbyclassname("subtable")
        Set dltable = dl(0).FirstChild.ChildNodes
        Set dlrow = dltable(10).getElementsByTagName("a")(2)
        dlrow.Click
        While objpage.ReadyState <> "complete"
            DoEvents
        Wend
    End If
    Application.Wait (Now() + TimeValue("0:00:05"))
    Set o = New CUIAutomation
    h = subpage.Hwnd
    fnb = FindWindowEx(h, 0, "Frame Notification Bar", vbNullString)
    If fnb = 0 Then Exit Sub
    'Debug.Print "type of fnb is " & TypeName(fnb)
    Set e = o.ElementFromHandle(ByVal fnb)
    'Debug.Print "type of e is " & TypeName(e)
    Set iCnd = o.CreatePropertyCondition(UIA_NamePropertyId, "Save")
    Set Button = e.FindFirst(TreeScope_Subtree, iCnd)
    'Debug.Print "type of Button is " & TypeName(Button)
    Set InvokePattern = Button.GetCurrentPattern(UIA_InvokePatternId)
    'Debug.Print "type of InvokePattern is " & TypeName(InvokePattern)
    InvokePattern.Invoke

End Sub

我尝试将"Save"更改为"Save as"，但是它不起作用.我的猜测是，在访问另存为"按钮之前，我需要先以某种方式能够单击拆分按钮上的箭头，但是这样做没有成功. 如果有人可以提供解决方案，我们将不胜感激.

I have tried changing "Save" to "Save as" but it doesn't work. My guess is that I need to somehow be able to click on the arrow on the split button first before accessing to the save as button but I have had no success in doing it. Gladly appreciate it if someone can offer a solution.

推荐答案

我只是尝试通过链接 http://www.tvsubtitles.net/download-114117.html ，可在网页

I tried simply to download a file by the link http://www.tvsubtitles.net/download-114117.html, which can be found on the webpage http://www.tvsubtitles.net/subtitle-114117.html, and it worked for me, here is the code:

Sub Test_download_tvsubtitles_net()

    DownloadFile "http://www.tvsubtitles.net/download-114117.html", ThisWorkbook.Path & "\download-114117.zip"

End Sub

Sub DownloadFile(sUrl, sPath)

    Dim aBody

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", sUrl, False
        .Send
        aBody = .responseBody
    End With
    With CreateObject("ADODB.Stream")
        .Type = 1 ' adTypeBinary
        .Open
        .Write aBody
        .SaveToFile sPath, 2 ' adSaveCreateOverWrite
        .Close
    End With

End Sub

这篇关于VBA-从Internet Explorer的框架通知栏中选择另存为的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！