Присвойте 2-ю вкладку IE переменной объекта - PullRequest
1 голос
/ 15 марта 2019

Полное назначение: программная загрузка файла XLS с веб-сайта DoD без необходимости доверять сертификату.

Подробно: я хочу взаимодействовать со второй вкладкой, которая открывается через мой код.В настоящее время код продолжает работать с первой вкладкой.В том, что я нашел в Интернете в последний час, это обычно делается путем проверки URL второй страницы.Проблема в том, что вторая страница имеет тот же URL, что и первая.Второй возникает из-за проблемы с сертификатом, которую я пытаюсь обойти.(Это не может исправить проблему с сертификатом.) Я просто хотел бы иметь возможность работать со второй вкладкой, так что если нам придется убить первую вкладку, это тоже будет хорошо.После того, как все мои ссылки будут нажаты, появится окно IE, спрашивающее, что бы я хотел сделать с файлом: Открыть, Сохранить или Сохранить как.Смогу ли я также контролировать эту коробку, чтобы она открывалась (потому что я трачу свое время, если нет)?Вот что у меня получилось ...

'http://www.exceltrainingvideos.com/how-to-follow-multiple-hyperlinks-and-extract-webpage-data/
Sub testweb()

mystart:

Set objIE = CreateObject("InternetExplorer.Application")
objIE.Top = 0
objIE.Left = 0
objIE.Width = 1600
objIE.Height = 900
objIE.Visible = True

On Error Resume Next
objIE.Navigate ("https://www.defensetravel.dod.mil/site/pdcFiles.cfm?dir=/Allowances/Per_Diem_Rates/Text_Only/OCONUS-Overseas/ovs19-01.xls")

Application.Wait (Now + TimeValue("0:00:04"))

Do
DoEvents
If Err.Number <> 0 Then
    objIE.Quit
    Set objIE = Nothing
    GoTo mystart:
End If
Loop Until objIE.ReadyState = 4

Set alllinks = objIE.document.getElementsByTagName("A")         'click year
For Each Hyperlink In alllinks
If InStr(Hyperlink.innertext, " 2019") > 0 Then
    Hyperlink.Click
Exit For
End If
Next

Application.Wait (Now + TimeValue("0:00:02"))

Set alllinks = objIE.document.getElementsByTagName("A")         'click file name
For Each Hyperlink In alllinks
    If InStr(Hyperlink.innertext, " ovs19-01.xls") > 0 Then         'item 45
        Hyperlink.Click
        Exit For
    End If
Next
Stop

Application.Wait (Now + TimeValue("0:00:04"))

Ниже я хочу, чтобы мой код начал работать со второй страницей **

Set alllinks = objIE.document.getElementsByTagName("A")         'click More Info link
For Each Hyperlink In alllinks
    If InStr(Hyperlink.innertext, "More information") > 0 Then
        Hyperlink.Click
        Exit For
    End If
Next
Stop

Application.Wait (Now + TimeValue("0:00:02"))

Set alllinks = objIE.document.getElementsByTagName("A")        'click Go on to the webpage...
For Each Hyperlink In aAlllinks
    If InStr(Hyperlink.innertext, "Go on to the webpage (not recommended)") > 0 Then
        Hyperlink.Click
        Exit For
    End If
Next
Stop

objIE.Quit

End Sub

1 Ответ

1 голос
/ 15 марта 2019

Вы можете использовать ссылку для скачивания direct и указать флаг предупреждения игнорирования сертификата

Option Explicit

Const IGNORE_SSL_ERROR_FLAG As Long = 13056
Public Sub GetFile()

    Debug.Print DownloadFile("C:\Users\User\Desktop\", "https://www.defensetravel.dod.mil/Docs/perdiem/browse/Allowances/Per_Diem_Rates/Text_Only/OCONUS-Overseas/2019/ovs19-03.xls")

End Sub
Public Function DownloadFile(ByVal downloadFolder As String, ByVal downloadURL As String) As String
    Dim http As Object, tempArr As Variant
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    http.Open "GET", downloadURL, False
    http.Option(4) = IGNORE_SSL_ERROR_FLAG
    http.send
    On Error GoTo errhand
    With CreateObject("ADODB.Stream")
        .Open
        .Type = 1
        .write http.responseBody
        tempArr = Split(downloadURL, "/")
        tempArr = tempArr(UBound(tempArr))
        .SaveToFile downloadFolder & tempArr, 2  '< "/" on enter of downloadFolder. 2 for overwrite which is Ok if no file modifications.
        .Close
    End With
    DownloadFile = downloadFolder & tempArr
    Exit Function
errhand:
    If Err.Number <> 0 Then
        Debug.Print Err.Number, Err.Description
        MsgBox "Download failed"
    End If
    DownloadFile = vbNullString
End Function
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...