VBA - wählen Sie Speichern als aus dem Rahmen Benachrichtigungsleiste des Internet Explorers

Question

Ich versuche, eine Datei mit Speichern als über die Frame-Benachrichtigungsleiste Internet Explorer herunterladen. Allerdings habe ich nach vielen Suchen nur Lösungen gefunden, die auf save in der Rahmenbenachrichtigungsleiste klicken. Bisher habe ich versucht, wie die Datei auf dem Probenort zu speichern:

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

mit dem folgenden Code:

' 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 

ich versucht habe "Save"-"Save as" ändern, aber es funktioniert nicht Arbeit. Meine Vermutung ist, dass ich irgendwie in der Lage sein muss, zuerst auf den Pfeil auf der Split-Taste zu klicken, bevor ich auf die Schaltfläche "Speichern unter" klicke, aber ich hatte keinen Erfolg dabei. Gerne zu schätzen, wenn jemand eine Lösung anbieten kann.

Answer 1

ich einfach versucht, eine Datei über den Link http://www.tvsubtitles.net/download-114117.html, herunterzuladen, die auf der Webseite zu finden sind http://www.tvsubtitles.net/subtitle-114117.html, und es funktionierte für mich, hier ist der 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